Agda 2.6.1.3 → 2.6.2

raw patch · 401 files changed

+42808/−29098 lines, 401 filesdep +case-insensitivedep +monad-controldep +paralleldep −geniplate-mirrordep −ieee754dep ~Win32dep ~basedep ~bytestringsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive, monad-control, parallel

Dependencies removed: geniplate-mirror, ieee754

Dependency ranges changed: Win32, base, bytestring, containers, directory, template-haskell, text, text-icu, time, transformers

API changes (from Hackage documentation)

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace o (Agda.Auto.Syntax.ArgList o) (Agda.Auto.Syntax.ArgList o)

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace o (Agda.Auto.Syntax.Exp o) (Agda.Auto.Syntax.MExp o)

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace o t u => Agda.Auto.CaseSplit.Replace o (Agda.Auto.NarrowingSearch.MM t (Agda.Auto.Syntax.RefInfo o)) u

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace o t u => Agda.Auto.CaseSplit.Replace o (Agda.Auto.Syntax.Abs t) (Agda.Auto.Syntax.Abs u)

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify o (Agda.Auto.Syntax.ArgList o)

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify o (Agda.Auto.Syntax.Exp o)

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify o t => Agda.Auto.CaseSplit.Unify o (Agda.Auto.NarrowingSearch.MM t (Agda.Auto.Syntax.RefInfo o))

- Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify o t => Agda.Auto.CaseSplit.Unify o (Agda.Auto.Syntax.Abs t)

- Agda.Auto.NarrowingSearch: instance Agda.Auto.NarrowingSearch.Trav a blk => Agda.Auto.NarrowingSearch.Trav (Agda.Auto.NarrowingSearch.MM a blk) blk

- Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.ArgList o) (Agda.Auto.Syntax.RefInfo o)

- Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.Exp o) (Agda.Auto.Syntax.RefInfo o)

- Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.MId, Agda.Auto.Syntax.CExp o) (Agda.Auto.Syntax.RefInfo o)

- Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.TrBr a o) (Agda.Auto.Syntax.RefInfo o)

- Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav a blk => Agda.Auto.NarrowingSearch.Trav [a] blk

- Agda.Benchmarking: instance Agda.Utils.Benchmark.MonadBench Agda.Benchmarking.Phase GHC.Types.IO

- Agda.Compiler.Backend: Guarded :: Constraint -> ProblemId -> Constraint

- Agda.Compiler.Backend: IlltypedPattern :: Pattern -> Type -> TypeError

- Agda.Compiler.Backend: IrrelevantDatatype :: Closure Type -> SplitError

- Agda.Compiler.Backend: ProblemId :: Nat -> ProblemId

- Agda.Compiler.Backend: TelCmp :: Type -> Type -> Comparison -> Telescope -> Telescope -> Constraint

- Agda.Compiler.Backend: YesGeneralize :: DoGeneralize

- Agda.Compiler.Backend: [dfFreeVars] :: DisplayForm -> Nat

- Agda.Compiler.Backend: [envCheckOptionConsistency] :: TCEnv -> Bool

- Agda.Compiler.Backend: [envModuleNestingLevel] :: TCEnv -> !Int

- Agda.Compiler.Backend: [iPragmaOptions] :: Interface -> [OptionsPragma]

- Agda.Compiler.Backend: eModuleNestingLevel :: Lens' Int TCEnv

- Agda.Compiler.Backend: getInputFile :: TCM AbsolutePath

- Agda.Compiler.Backend: getInputFile' :: TCM (Maybe AbsolutePath)

- Agda.Compiler.Backend: hasInputFile :: HasOptions m => m Bool

- Agda.Compiler.Backend: ignoreAllInterfaces :: HasOptions m => m Bool

- Agda.Compiler.Backend: ignoreInterfaces :: HasOptions m => m Bool

- Agda.Compiler.Backend: isVisited :: TopLevelModuleName -> TCM Bool

- Agda.Compiler.Backend: mapVisitedModule :: TopLevelModuleName -> (ModuleInfo -> ModuleInfo) -> TCM ()

- Agda.Compiler.Backend: newtype ProblemId

- Agda.Compiler.Backend: runIM :: IM a -> TCM a

- Agda.Compiler.Backend: setInputFile :: FilePath -> TCM ()

- Agda.Compiler.Backend: setMetaArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m ()

- Agda.Compiler.Backend: type IM = TCMT (InputT IO)

- Agda.Compiler.Backend: withIncreasedModuleNestingLevel :: TCM a -> TCM a

- Agda.Compiler.Backend: withoutOptionsChecking :: TCM a -> TCM a

- Agda.Compiler.Common: curSig :: TCM Signature

- Agda.Compiler.Common: sigMName :: Signature -> ModuleName

- Agda.Compiler.JS.Compiler: compileTerm' :: Maybe CoinductionKit -> TTerm -> TCM Exp

- Agda.Compiler.JS.Compiler: copyRTEModules :: TCM ()

- Agda.Compiler.JS.Compiler: curModule :: IsMain -> TCM Module

- Agda.Compiler.JS.Pretty: block' :: Nat -> Int -> Exp -> String

- Agda.Compiler.JS.Pretty: br :: Int -> String

- Agda.Compiler.JS.Syntax: [postscript] :: Module -> Maybe Exp

- Agda.Compiler.JS.Syntax: newtype MemberId

- Agda.Compiler.MAlonzo.Compiler: [optGhcCompile] :: GHCOptions -> Bool

- Agda.Compiler.MAlonzo.Compiler: defaultGHCOptions :: GHCOptions

- Agda.Compiler.MAlonzo.Compiler: outFile :: ModuleName -> TCM FilePath

- Agda.Compiler.MAlonzo.Compiler: outFile' :: Pretty a => a -> TCM (FilePath, FilePath)

- Agda.Compiler.MAlonzo.Compiler: outFile_ :: TCM FilePath

- Agda.Compiler.MAlonzo.Compiler: type GHCModuleEnv = ()

- Agda.Compiler.MAlonzo.Misc: mazerror :: String -> a

- Agda.Compiler.MAlonzo.Primitives: hasMainFunction :: IsMain -> Interface -> IsMain

- Agda.Compiler.MAlonzo.Primitives: isMainFunction :: QName -> Defn -> Bool

- Agda.Compiler.MAlonzo.Primitives: pconName :: String -> TCM String

- Agda.Compiler.Treeless.Subst: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Treeless.TTerm Agda.Syntax.Treeless.TAlt

- Agda.Compiler.Treeless.Subst: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Treeless.TTerm Agda.Syntax.Treeless.TTerm

- Agda.Interaction.Base: Guard :: OutputConstraint a b -> ProblemId -> OutputConstraint a b

- Agda.Interaction.BasicOps: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a c, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete b d) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Interaction.Base.OutputConstraint a b) (Agda.Interaction.Base.OutputConstraint c d)

- Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a c => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.TypeChecking.Monad.Base.IPBoundary' a) (Agda.TypeChecking.Monad.Base.IPBoundary' c)

- Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.Constraint (Agda.Interaction.Base.OutputConstraint Agda.Syntax.Abstract.Expr Agda.Syntax.Abstract.Expr)

- Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.ProblemConstraint (Agda.TypeChecking.Monad.Base.Closure (Agda.Interaction.Base.OutputForm Agda.Syntax.Abstract.Expr Agda.Syntax.Abstract.Expr))

- Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.InternalToAbstract.Reify a e => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.TypeChecking.Monad.Base.IPBoundary' a) (Agda.TypeChecking.Monad.Base.IPBoundary' e)

- Agda.Interaction.CommandLine: Continue :: ExitCode a

- Agda.Interaction.CommandLine: ContinueIn :: TCEnv -> ExitCode a

- Agda.Interaction.CommandLine: Return :: a -> ExitCode a

- Agda.Interaction.CommandLine: actOnMeta :: [String] -> (InteractionId -> Expr -> TCM a) -> TCM a

- Agda.Interaction.CommandLine: continueAfter :: TCM a -> TCM (ExitCode b)

- Agda.Interaction.CommandLine: data ExitCode a

- Agda.Interaction.CommandLine: evalIn :: [String] -> TCM ()

- Agda.Interaction.CommandLine: evalTerm :: String -> TCM (ExitCode a)

- Agda.Interaction.CommandLine: giveMeta :: [String] -> TCM ()

- Agda.Interaction.CommandLine: help :: [Command a] -> IO ()

- Agda.Interaction.CommandLine: interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> IM a

- Agda.Interaction.CommandLine: interactionLoop :: TCM (Maybe Interface) -> IM ()

- Agda.Interaction.CommandLine: loadFile :: TCM () -> [String] -> TCM ()

- Agda.Interaction.CommandLine: matchCommand :: String -> [Command a] -> Either [String] ([String] -> TCM (ExitCode a))

- Agda.Interaction.CommandLine: metaParseExpr :: InteractionId -> String -> TCM Expr

- Agda.Interaction.CommandLine: parseExpr :: String -> TCM Expr

- Agda.Interaction.CommandLine: refineMeta :: [String] -> TCM ()

- Agda.Interaction.CommandLine: retryConstraints :: TCM ()

- Agda.Interaction.CommandLine: showConstraints :: [String] -> TCM ()

- Agda.Interaction.CommandLine: showContext :: [String] -> TCM ()

- Agda.Interaction.CommandLine: showMetas :: [String] -> TCM ()

- Agda.Interaction.CommandLine: showScope :: TCM ()

- Agda.Interaction.CommandLine: splashScreen :: String

- Agda.Interaction.CommandLine: type Command a = (String, [String] -> TCM (ExitCode a))

- Agda.Interaction.CommandLine: typeIn :: [String] -> TCM ()

- Agda.Interaction.CommandLine: typeOf :: [String] -> TCM ()

- Agda.Interaction.CommandLine: withCurrentFile :: TCM a -> TCM a

- Agda.Interaction.EmacsCommand: instance GHC.Show.Show (Agda.Interaction.EmacsCommand.Lisp GHC.Base.String)

- Agda.Interaction.Highlighting.Dot: DotState :: Map ModuleName ModuleId -> [ModuleId] -> Set (ModuleId, ModuleId) -> DotState

- Agda.Interaction.Highlighting.Dot: [dsConnection] :: DotState -> Set (ModuleId, ModuleId)

- Agda.Interaction.Highlighting.Dot: [dsModules] :: DotState -> Map ModuleName ModuleId

- Agda.Interaction.Highlighting.Dot: [dsNameSupply] :: DotState -> [ModuleId]

- Agda.Interaction.Highlighting.Dot: addConnection :: ModuleId -> ModuleId -> DotM ()

- Agda.Interaction.Highlighting.Dot: addModule :: ModuleName -> DotM (ModuleId, Bool)

- Agda.Interaction.Highlighting.Dot: data DotState

- Agda.Interaction.Highlighting.Dot: dottify :: Interface -> DotM ModuleId

- Agda.Interaction.Highlighting.Dot: generateDot :: Interface -> TCM ()

- Agda.Interaction.Highlighting.Dot: initialDotState :: DotState

- Agda.Interaction.Highlighting.Dot: type DotM = StateT DotState TCM

- Agda.Interaction.Highlighting.Dot: type ModuleId = String

- Agda.Interaction.Highlighting.Generate: computeUnsolvedConstraints :: TCM File

- Agda.Interaction.Highlighting.Generate: computeUnsolvedMetaWarnings :: TCM File

- Agda.Interaction.Highlighting.Generate: storeDisambiguatedName :: QName -> TCM ()

- Agda.Interaction.Highlighting.HTML: code :: Bool -> FileType -> [TokenInfo] -> Html

- Agda.Interaction.Highlighting.HTML: defaultCSSFile :: FilePath

- Agda.Interaction.Highlighting.HTML: generateHTML :: TCM ()

- Agda.Interaction.Highlighting.HTML: generateHTMLWithPageGen :: PageGen -> TCM ()

- Agda.Interaction.Highlighting.HTML: generatePage :: (FilePath -> FilePath -> Text) -> String -> FilePath -> TopLevelModuleName -> TCM ()

- Agda.Interaction.Highlighting.HTML: page :: FilePath -> Bool -> TopLevelModuleName -> Html -> Text

- Agda.Interaction.Highlighting.HTML: tokenStream :: Text -> CompressedFile -> [TokenInfo]

- Agda.Interaction.Highlighting.LaTeX: generateLaTeX :: Interface -> TCM ()

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Classes.Eq Agda.Interaction.Highlighting.LaTeX.Debug

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Classes.Eq Agda.Interaction.Highlighting.LaTeX.Kind

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Show.Show Agda.Interaction.Highlighting.LaTeX.AlignmentColumn

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Show.Show Agda.Interaction.Highlighting.LaTeX.Debug

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Show.Show Agda.Interaction.Highlighting.LaTeX.Kind

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Show.Show Agda.Interaction.Highlighting.LaTeX.Output

- Agda.Interaction.Highlighting.LaTeX: instance GHC.Show.Show Agda.Interaction.Highlighting.LaTeX.Token

- Agda.Interaction.Highlighting.Precise: CompressedFile :: [(Range, Aspects)] -> CompressedFile

- Agda.Interaction.Highlighting.Precise: File :: IntMap Aspects -> File

- Agda.Interaction.Highlighting.Precise: [mapping] :: File -> IntMap Aspects

- Agda.Interaction.Highlighting.Precise: [ranges] :: CompressedFile -> [(Range, Aspects)]

- Agda.Interaction.Highlighting.Precise: compress :: File -> CompressedFile

- Agda.Interaction.Highlighting.Precise: compressedFileInvariant :: CompressedFile -> Bool

- Agda.Interaction.Highlighting.Precise: decompress :: CompressedFile -> File

- Agda.Interaction.Highlighting.Precise: instance GHC.Base.Monoid Agda.Interaction.Highlighting.Precise.CompressedFile

- Agda.Interaction.Highlighting.Precise: instance GHC.Base.Monoid Agda.Interaction.Highlighting.Precise.File

- Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Precise.CompressedFile

- Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Precise.File

- Agda.Interaction.Highlighting.Precise: instance GHC.Classes.Eq Agda.Interaction.Highlighting.Precise.CompressedFile

- Agda.Interaction.Highlighting.Precise: instance GHC.Classes.Eq Agda.Interaction.Highlighting.Precise.File

- Agda.Interaction.Highlighting.Precise: instance GHC.Show.Show Agda.Interaction.Highlighting.Precise.CompressedFile

- Agda.Interaction.Highlighting.Precise: instance GHC.Show.Show Agda.Interaction.Highlighting.Precise.File

- Agda.Interaction.Highlighting.Precise: merge :: File -> File -> File

- Agda.Interaction.Highlighting.Precise: mergeC :: CompressedFile -> CompressedFile -> CompressedFile

- Agda.Interaction.Highlighting.Precise: newtype CompressedFile

- Agda.Interaction.Highlighting.Precise: newtype File

- Agda.Interaction.Highlighting.Precise: noHighlightingInRange :: Ranges -> CompressedFile -> CompressedFile

- Agda.Interaction.Highlighting.Precise: selectC :: Range -> CompressedFile -> CompressedFile

- Agda.Interaction.Highlighting.Precise: severalC :: [Ranges] -> Aspects -> CompressedFile

- Agda.Interaction.Highlighting.Precise: singletonC :: Ranges -> Aspects -> CompressedFile

- Agda.Interaction.Highlighting.Precise: smallestPos :: File -> Maybe Int

- Agda.Interaction.Highlighting.Precise: smallestPosC :: CompressedFile -> Maybe Int

- Agda.Interaction.Highlighting.Precise: splitAtC :: Int -> CompressedFile -> (CompressedFile, CompressedFile)

- Agda.Interaction.Highlighting.Range: rangeToEndPoints :: Range -> Maybe (Int, Int)

- Agda.Interaction.Imports: MainInterface :: Mode -> MainInterface

- Agda.Interaction.Imports: NoWarnings :: MaybeWarnings' a

- Agda.Interaction.Imports: NotMainInterface :: MainInterface

- Agda.Interaction.Imports: ScopeCheck :: Mode

- Agda.Interaction.Imports: SomeWarnings :: a -> MaybeWarnings' a

- Agda.Interaction.Imports: SourceInfo :: Text -> FileType -> Module -> TopLevelModuleName -> SourceInfo

- Agda.Interaction.Imports: TypeCheck :: Mode

- Agda.Interaction.Imports: [siFileType] :: SourceInfo -> FileType

- Agda.Interaction.Imports: [siModuleName] :: SourceInfo -> TopLevelModuleName

- Agda.Interaction.Imports: [siModule] :: SourceInfo -> Module

- Agda.Interaction.Imports: [siSource] :: SourceInfo -> Text

- Agda.Interaction.Imports: addImportedThings :: Signature -> BuiltinThings PrimFun -> PatternSynDefns -> DisplayForms -> Map QName String -> Set QName -> [TCWarning] -> TCM ()

- Agda.Interaction.Imports: alreadyVisited :: TopLevelModuleName -> MainInterface -> PragmaOptions -> TCM (Interface, MaybeWarnings) -> TCM (Interface, MaybeWarnings)

- Agda.Interaction.Imports: applyFlagsToMaybeWarnings :: MaybeWarnings -> TCM MaybeWarnings

- Agda.Interaction.Imports: buildInterface :: Text -> FileType -> TopLevelInfo -> [OptionsPragma] -> TCM Interface

- Agda.Interaction.Imports: chaseMsg :: String -> TopLevelModuleName -> Maybe String -> TCM ()

- Agda.Interaction.Imports: checkOptionsCompatible :: PragmaOptions -> PragmaOptions -> ModuleName -> TCM Bool

- Agda.Interaction.Imports: concreteOptionsToOptionPragmas :: [Pragma] -> TCM [OptionsPragma]

- Agda.Interaction.Imports: constructIScope :: Interface -> Interface

- Agda.Interaction.Imports: createInterface :: SourceFile -> TopLevelModuleName -> MainInterface -> Maybe SourceInfo -> TCM (Interface, MaybeWarnings)

- Agda.Interaction.Imports: data MainInterface

- Agda.Interaction.Imports: data MaybeWarnings' a

- Agda.Interaction.Imports: data SourceInfo

- Agda.Interaction.Imports: getAllUnsolved :: TCM [TCWarning]

- Agda.Interaction.Imports: getAllWarnings :: WhichWarnings -> TCM [TCWarning]

- Agda.Interaction.Imports: getAllWarnings' :: MainInterface -> WhichWarnings -> TCM [TCWarning]

- Agda.Interaction.Imports: getAllWarningsOfTCErr :: TCErr -> TCM [TCWarning]

- Agda.Interaction.Imports: getInterface :: ModuleName -> TCM Interface

- Agda.Interaction.Imports: getInterface' :: TopLevelModuleName -> MainInterface -> Maybe SourceInfo -> TCM (Interface, MaybeWarnings)

- Agda.Interaction.Imports: getInterfaceFileHashes :: AbsolutePath -> TCM (Maybe (Hash, Hash))

- Agda.Interaction.Imports: getInterfaceFileHashes' :: InterfaceFile -> TCM (Maybe (Hash, Hash))

- Agda.Interaction.Imports: getInterface_ :: TopLevelModuleName -> Maybe SourceInfo -> TCM Interface

- Agda.Interaction.Imports: getMaybeWarnings :: WhichWarnings -> TCM MaybeWarnings

- Agda.Interaction.Imports: getMaybeWarnings' :: MainInterface -> WhichWarnings -> TCM MaybeWarnings

- Agda.Interaction.Imports: getStoredInterface :: TopLevelModuleName -> SourceFile -> MainInterface -> Maybe SourceInfo -> TCM (Bool, (Interface, MaybeWarnings))

- Agda.Interaction.Imports: getUniqueMetasRanges :: [MetaId] -> TCM [Range]

- Agda.Interaction.Imports: getUnsolvedMetas :: TCM [Range]

- Agda.Interaction.Imports: hasWarnings :: MaybeWarnings -> Bool

- Agda.Interaction.Imports: highlightFromInterface :: Interface -> SourceFile -> TCM ()

- Agda.Interaction.Imports: includeStateChanges :: MainInterface -> Bool

- Agda.Interaction.Imports: instance Agda.Utils.Null.Null a => Agda.Utils.Null.Null (Agda.Interaction.Imports.MaybeWarnings' a)

- Agda.Interaction.Imports: instance Data.Foldable.Foldable Agda.Interaction.Imports.MaybeWarnings'

- Agda.Interaction.Imports: instance Data.Traversable.Traversable Agda.Interaction.Imports.MaybeWarnings'

- Agda.Interaction.Imports: instance GHC.Base.Functor Agda.Interaction.Imports.MaybeWarnings'

- Agda.Interaction.Imports: instance GHC.Show.Show a => GHC.Show.Show (Agda.Interaction.Imports.MaybeWarnings' a)

- Agda.Interaction.Imports: isCached :: TopLevelModuleName -> SourceFile -> MaybeT TCM Interface

- Agda.Interaction.Imports: isNewerThan :: FilePath -> FilePath -> IO Bool

- Agda.Interaction.Imports: mergeInterface :: Interface -> TCM ()

- Agda.Interaction.Imports: moduleHash :: ModuleName -> TCM Hash

- Agda.Interaction.Imports: readInterface' :: InterfaceFile -> TCM (Maybe Interface)

- Agda.Interaction.Imports: removePrivates :: ScopeInfo -> ScopeInfo

- Agda.Interaction.Imports: sourceInfo :: SourceFile -> TCM SourceInfo

- Agda.Interaction.Imports: type MaybeWarnings = MaybeWarnings' [TCWarning]

- Agda.Interaction.Imports: typeCheck :: TopLevelModuleName -> SourceFile -> MainInterface -> Maybe SourceInfo -> TCM (Bool, (Interface, MaybeWarnings))

- Agda.Interaction.Imports: writeInterface :: AbsolutePath -> Interface -> TCM Interface

- Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.TypeChecking.Monad.Base.ProblemId

- Agda.Interaction.JSONTop: instance Data.Aeson.Types.ToJSON.ToJSON Agda.TypeChecking.Monad.Base.ProblemId

- Agda.Interaction.Library: instance Agda.Utils.Pretty.Pretty Agda.Interaction.Library.LibWarning

- Agda.Interaction.Library: instance Agda.Utils.Pretty.Pretty Agda.Interaction.Library.Parse.LibWarning'

- Agda.Interaction.Library: instance Data.Data.Data Agda.Interaction.Library.LibPositionInfo

- Agda.Interaction.Library: instance Data.Data.Data Agda.Interaction.Library.LibWarning

- Agda.Interaction.Library: instance GHC.Show.Show Agda.Interaction.Library.LibError'

- Agda.Interaction.Library: instance GHC.Show.Show Agda.Interaction.Library.LibPositionInfo

- Agda.Interaction.Library: instance GHC.Show.Show Agda.Interaction.Library.LibWarning

- Agda.Interaction.Library: instance GHC.Show.Show Agda.Interaction.Library.LibrariesFile

- Agda.Interaction.Library.Parse: UnknownField :: String -> LibWarning'

- Agda.Interaction.Library.Parse: data LibWarning'

- Agda.Interaction.Library.Parse: instance Data.Data.Data Agda.Interaction.Library.Parse.LibWarning'

- Agda.Interaction.Library.Parse: instance GHC.Show.Show Agda.Interaction.Library.Parse.LibWarning'

- Agda.Interaction.Library.Parse: type LineNumber = Int

- Agda.Interaction.Monad: type IM = TCMT (InputT IO)

- Agda.Interaction.Options: HighlightAll :: HtmlHighlight

- Agda.Interaction.Options: HighlightAuto :: HtmlHighlight

- Agda.Interaction.Options: HighlightCode :: HtmlHighlight

- Agda.Interaction.Options: [optCSSFile] :: CommandLineOptions -> Maybe FilePath

- Agda.Interaction.Options: [optCompareSorts] :: PragmaOptions -> Bool

- Agda.Interaction.Options: [optDependencyGraph] :: CommandLineOptions -> Maybe FilePath

- Agda.Interaction.Options: [optGenerateHTML] :: CommandLineOptions -> Bool

- Agda.Interaction.Options: [optGenerateLaTeX] :: CommandLineOptions -> Bool

- Agda.Interaction.Options: [optHTMLDir] :: CommandLineOptions -> FilePath

- Agda.Interaction.Options: [optHTMLHighlight] :: CommandLineOptions -> HtmlHighlight

- Agda.Interaction.Options: [optLaTeXDir] :: CommandLineOptions -> FilePath

- Agda.Interaction.Options: [optShowHelp] :: CommandLineOptions -> Maybe Help

- Agda.Interaction.Options: [optShowVersion] :: CommandLineOptions -> Bool

- Agda.Interaction.Options: [optWithCompiler] :: CommandLineOptions -> Maybe FilePath

- Agda.Interaction.Options: data HtmlHighlight

- Agda.Interaction.Options: defaultLibDir :: IO FilePath

- Agda.Interaction.Options: instance GHC.Classes.Eq Agda.Interaction.Options.HtmlHighlight

- Agda.Interaction.Options: instance GHC.Classes.Eq Agda.Interaction.Options.PragmaOptions

- Agda.Interaction.Options: instance GHC.Classes.Eq Agda.Interaction.Options.RestartCodomain

- Agda.Interaction.Options: instance GHC.Show.Show Agda.Interaction.Options.CommandLineOptions

- Agda.Interaction.Options: instance GHC.Show.Show Agda.Interaction.Options.HtmlHighlight

- Agda.Interaction.Options: instance GHC.Show.Show Agda.Interaction.Options.PragmaOptions

- Agda.Interaction.Options.IORefs: AsciiOnly :: UnicodeOrAscii

- Agda.Interaction.Options.IORefs: UnicodeOk :: UnicodeOrAscii

- Agda.Interaction.Options.IORefs: data UnicodeOrAscii

- Agda.Interaction.Options.IORefs: unicodeOrAscii :: IORef UnicodeOrAscii

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensIncludePaths Agda.Interaction.Options.CommandLineOptions

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensPersistentVerbosity Agda.Interaction.Options.CommandLineOptions

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensPersistentVerbosity Agda.Interaction.Options.PragmaOptions

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensPragmaOptions Agda.Interaction.Options.CommandLineOptions

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensSafeMode Agda.Interaction.Options.CommandLineOptions

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensSafeMode Agda.Interaction.Options.PragmaOptions

- Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensVerbosity Agda.Interaction.Options.PragmaOptions

- Agda.Main: builtinBackends :: [Backend]

- Agda.Main: defaultInteraction :: CommandLineOptions -> TCM (Maybe Interface) -> TCM ()

- Agda.Main: main :: IO ()

- Agda.Syntax.Abstract: AmbQ :: NonEmpty QName -> AmbiguousQName

- Agda.Syntax.Abstract: Def :: QName -> Expr

- Agda.Syntax.Abstract: FunSig :: Axiom

- Agda.Syntax.Abstract: MName :: [Name] -> ModuleName

- Agda.Syntax.Abstract: Name :: !NameId -> Name -> Range -> Fixity' -> Bool -> Name

- Agda.Syntax.Abstract: NoFunSig :: Axiom

- Agda.Syntax.Abstract: Prop :: ExprInfo -> Integer -> Expr

- Agda.Syntax.Abstract: QName :: ModuleName -> Name -> QName

- Agda.Syntax.Abstract: QNamed :: QName -> a -> QNamed a

- Agda.Syntax.Abstract: Set :: ExprInfo -> Integer -> Expr

- Agda.Syntax.Abstract: [mnameToList] :: ModuleName -> [Name]

- Agda.Syntax.Abstract: [nameBindingSite] :: Name -> Range

- Agda.Syntax.Abstract: [nameConcrete] :: Name -> Name

- Agda.Syntax.Abstract: [nameFixity] :: Name -> Fixity'

- Agda.Syntax.Abstract: [nameId] :: Name -> !NameId

- Agda.Syntax.Abstract: [nameIsRecordName] :: Name -> Bool

- Agda.Syntax.Abstract: [qnameModule] :: QName -> ModuleName

- Agda.Syntax.Abstract: [qnameName] :: QName -> Name

- Agda.Syntax.Abstract: [qname] :: QNamed a -> QName

- Agda.Syntax.Abstract: [qnamed] :: QNamed a -> a

- Agda.Syntax.Abstract: [unAmbQ] :: AmbiguousQName -> NonEmpty QName

- Agda.Syntax.Abstract: allNames :: AllNames a => a -> Seq QName

- Agda.Syntax.Abstract: class AllNames a

- Agda.Syntax.Abstract: class IsNoName a

- Agda.Syntax.Abstract: class IsProjP a

- Agda.Syntax.Abstract: class MkName a

- Agda.Syntax.Abstract: commonParentModule :: ModuleName -> ModuleName -> ModuleName

- Agda.Syntax.Abstract: data Axiom

- Agda.Syntax.Abstract: data Name

- Agda.Syntax.Abstract: data QName

- Agda.Syntax.Abstract: data QNamed a

- Agda.Syntax.Abstract: getUnambiguous :: AmbiguousQName -> Maybe QName

- Agda.Syntax.Abstract: headAmbQ :: AmbiguousQName -> QName

- Agda.Syntax.Abstract: instance (Agda.Syntax.Abstract.AllNames a, Agda.Syntax.Abstract.AllNames b) => Agda.Syntax.Abstract.AllNames (a, b)

- Agda.Syntax.Abstract: instance (Agda.Syntax.Abstract.AllNames a, Agda.Syntax.Abstract.AllNames b, Agda.Syntax.Abstract.AllNames c) => Agda.Syntax.Abstract.AllNames (a, b, c)

- Agda.Syntax.Abstract: instance (Agda.Syntax.Abstract.AllNames qn, Agda.Syntax.Abstract.AllNames e) => Agda.Syntax.Abstract.AllNames (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.Clause

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.Declaration

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.Expr

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.LamBinding

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.LetBinding

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.ModuleApplication

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.Name.QName

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.RHS

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.TypedBinding

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames Agda.Syntax.Abstract.WhereDeclarations

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames a => Agda.Syntax.Abstract.AllNames (Agda.Syntax.Common.Arg a)

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames a => Agda.Syntax.Abstract.AllNames (Agda.Syntax.Common.Named name a)

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames a => Agda.Syntax.Abstract.AllNames (GHC.Maybe.Maybe a)

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.AllNames a => Agda.Syntax.Abstract.AllNames [a]

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.SubstExpr Agda.Syntax.Abstract.Assign

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.SubstExpr Agda.Syntax.Abstract.LetBinding

- Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.SubstExpr Agda.Syntax.Abstract.TypedBinding

- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.Axiom

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration (Agda.Syntax.Abstract.Pattern' Data.Void.Void)

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.BindName)

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Expr)

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.LHSCore)

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern)

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.Declaration

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.Expr

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.LamBinding

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.LetBinding

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.Name.AmbiguousQName

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.Name.ModuleName

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.Name.QName

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.Pattern

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Abstract.TypedBinding

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Common.Quantity

- Agda.Syntax.Abstract: instance Data.Generics.Geniplate.UniverseBi Agda.Syntax.Abstract.Declaration Agda.Syntax.Info.ModuleInfo

- Agda.Syntax.Abstract: instance GHC.Classes.Eq Agda.Syntax.Abstract.Axiom

- Agda.Syntax.Abstract: instance GHC.Classes.Ord Agda.Syntax.Abstract.Axiom

- Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.Axiom

- Agda.Syntax.Abstract: isAmbiguous :: AmbiguousQName -> Bool

- Agda.Syntax.Abstract: isAnonymousModuleName :: ModuleName -> Bool

- Agda.Syntax.Abstract: isInModule :: QName -> ModuleName -> Bool

- Agda.Syntax.Abstract: isLeChildModuleOf :: ModuleName -> ModuleName -> Bool

- Agda.Syntax.Abstract: isLeParentModuleOf :: ModuleName -> ModuleName -> Bool

- Agda.Syntax.Abstract: isLtChildModuleOf :: ModuleName -> ModuleName -> Bool

- Agda.Syntax.Abstract: isLtParentModuleOf :: ModuleName -> ModuleName -> Bool

- Agda.Syntax.Abstract: isNoName :: (IsNoName a, Foldable t, IsNoName b, t b ~ a) => a -> Bool

- Agda.Syntax.Abstract: isOperator :: QName -> Bool

- Agda.Syntax.Abstract: isProjP :: IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)

- Agda.Syntax.Abstract: lensQNameName :: Lens' Name QName

- Agda.Syntax.Abstract: mkName :: MkName a => Range -> NameId -> a -> Name

- Agda.Syntax.Abstract: mkName_ :: MkName a => NameId -> a -> Name

- Agda.Syntax.Abstract: mnameFromList :: [Name] -> ModuleName

- Agda.Syntax.Abstract: mnameToConcrete :: ModuleName -> QName

- Agda.Syntax.Abstract: mnameToQName :: ModuleName -> QName

- Agda.Syntax.Abstract: nameToArgName :: Name -> ArgName

- Agda.Syntax.Abstract: namedArgName :: NamedArg Name -> ArgName

- Agda.Syntax.Abstract: newtype AmbiguousQName

- Agda.Syntax.Abstract: newtype ModuleName

- Agda.Syntax.Abstract: nextName :: Name -> Name

- Agda.Syntax.Abstract: noModuleName :: ModuleName

- Agda.Syntax.Abstract: qnameFromList :: [Name] -> QName

- Agda.Syntax.Abstract: qnameToConcrete :: QName -> QName

- Agda.Syntax.Abstract: qnameToList :: QName -> [Name]

- Agda.Syntax.Abstract: qnameToMName :: QName -> ModuleName

- Agda.Syntax.Abstract: qualify :: ModuleName -> Name -> QName

- Agda.Syntax.Abstract: qualifyM :: ModuleName -> ModuleName -> ModuleName

- Agda.Syntax.Abstract: qualifyQ :: ModuleName -> QName -> QName

- Agda.Syntax.Abstract: qualify_ :: Name -> QName

- Agda.Syntax.Abstract: sameRoot :: Name -> Name -> Bool

- Agda.Syntax.Abstract: showQNameId :: QName -> String

- Agda.Syntax.Abstract: toTopLevelModuleName :: ModuleName -> TopLevelModuleName

- Agda.Syntax.Abstract: uglyShowName :: Name -> String

- Agda.Syntax.Abstract: unambiguous :: QName -> AmbiguousQName

- Agda.Syntax.Abstract: withRangesOf :: ModuleName -> [Name] -> ModuleName

- Agda.Syntax.Abstract: withRangesOfQ :: ModuleName -> QName -> ModuleName

- Agda.Syntax.Abstract.Pattern: instance (Agda.Syntax.Abstract.Pattern.APatternLike a b, Agda.Syntax.Abstract.Pattern.APatternLike a c) => Agda.Syntax.Abstract.Pattern.APatternLike a (b, c)

- Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a (Agda.Syntax.Abstract.Pattern' a)

- Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a b => Agda.Syntax.Abstract.Pattern.APatternLike a (Agda.Syntax.Common.Arg b)

- Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a b => Agda.Syntax.Abstract.Pattern.APatternLike a (Agda.Syntax.Common.Named n b)

- Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a b => Agda.Syntax.Abstract.Pattern.APatternLike a (Agda.Syntax.Concrete.FieldAssignment' b)

- Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a b => Agda.Syntax.Abstract.Pattern.APatternLike a (GHC.Maybe.Maybe b)

- Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a b => Agda.Syntax.Abstract.Pattern.APatternLike a [b]

- 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 p e)

- Agda.Syntax.Abstract.Views: isSet :: Expr -> Bool

- Agda.Syntax.Common: IsData :: DataOrRecord

- Agda.Syntax.Common: IsRecord :: DataOrRecord

- Agda.Syntax.Common: data DataOrRecord

- Agda.Syntax.Common: data HasEta

- 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 p e)

- Agda.Syntax.Common: instance (Agda.Syntax.Position.KillRange qn, Agda.Syntax.Position.KillRange e, Agda.Syntax.Position.KillRange p) => Agda.Syntax.Position.KillRange (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Common: instance (Agda.Utils.Pretty.Pretty p, Agda.Utils.Pretty.Pretty e) => Agda.Utils.Pretty.Pretty (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Common: instance (Control.DeepSeq.NFData qn, Control.DeepSeq.NFData p, Control.DeepSeq.NFData e) => Control.DeepSeq.NFData (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Common: instance (Data.Data.Data qn, Data.Data.Data p, Data.Data.Data e) => Data.Data.Data (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Common: instance (GHC.Classes.Eq qn, GHC.Classes.Eq e, GHC.Classes.Eq p) => GHC.Classes.Eq (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Common: instance (GHC.Show.Show qn, GHC.Show.Show e, GHC.Show.Show p) => GHC.Show.Show (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Common: instance Agda.Syntax.Common.LensNamed name (Agda.Syntax.Common.Named name a)

- Agda.Syntax.Common: instance Agda.Syntax.Common.LensNamed name (GHC.Maybe.Maybe name)

- Agda.Syntax.Common: instance Agda.Syntax.Common.LensNamed name a => Agda.Syntax.Common.LensNamed name (Agda.Syntax.Common.Arg a)

- Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid Agda.Syntax.Common.Cohesion

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid Agda.Syntax.Common.Modality

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid Agda.Syntax.Common.Quantity

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid Agda.Syntax.Common.Relevance

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid Agda.Syntax.Common.Cohesion

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid Agda.Syntax.Common.Modality

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid Agda.Syntax.Common.Quantity

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid Agda.Syntax.Common.Relevance

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup Agda.Syntax.Common.Cohesion

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup Agda.Syntax.Common.Modality

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup Agda.Syntax.Common.Quantity

- Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup Agda.Syntax.Common.Relevance

- Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.DataOrRecord

- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: instance Data.Foldable.Foldable (Agda.Syntax.Common.RewriteEqn' qn p)

- Agda.Syntax.Common: instance Data.Traversable.Traversable (Agda.Syntax.Common.RewriteEqn' qn p)

- Agda.Syntax.Common: instance GHC.Base.Functor (Agda.Syntax.Common.RewriteEqn' qn p)

- Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.Cohesion

- Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.Modality

- Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.Quantity

- Agda.Syntax.Common: instance GHC.Base.Monoid Agda.Syntax.Common.Relevance

- Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.Cohesion

- Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.Modality

- Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.Quantity

- Agda.Syntax.Common: instance GHC.Base.Semigroup Agda.Syntax.Common.Relevance

- Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.DataOrRecord

- Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.DataOrRecord

- Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.DataOrRecord

- Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.HasEta

- Agda.Syntax.Common: inverseApplyModality :: LensModality a => Modality -> a -> a

- Agda.Syntax.Concrete: Prop :: Range -> Expr

- Agda.Syntax.Concrete: PropN :: Range -> Integer -> Expr

- Agda.Syntax.Concrete: Set :: Range -> Expr

- Agda.Syntax.Concrete: SetN :: Range -> Integer -> Expr

- Agda.Syntax.Concrete: [lamWhere] :: LamClause -> WhereClause

- Agda.Syntax.Concrete: [lhsExpandedEllipsis] :: LHS -> ExpandedEllipsis

- Agda.Syntax.Concrete: countTelVars :: Telescope -> Nat

- Agda.Syntax.Concrete: instance Data.Foldable.Foldable (Agda.Syntax.Concrete.HoleContent' qn p)

- Agda.Syntax.Concrete: instance Data.Traversable.Traversable (Agda.Syntax.Concrete.HoleContent' qn p)

- Agda.Syntax.Concrete: instance GHC.Base.Functor (Agda.Syntax.Concrete.HoleContent' qn p)

- Agda.Syntax.Concrete: removeSingletonRawAppP :: Pattern -> Pattern

- Agda.Syntax.Concrete: type Module = ([Pragma], [Declaration])

- Agda.Syntax.Concrete.Definitions: AmbiguousFunClauses :: LHS -> [Name] -> DeclarationException

- Agda.Syntax.Concrete.Definitions: BadMacroDef :: NiceDeclaration -> DeclarationException

- Agda.Syntax.Concrete.Definitions: DeclarationPanic :: String -> DeclarationException

- Agda.Syntax.Concrete.Definitions: DuplicateDefinition :: Name -> DeclarationException

- Agda.Syntax.Concrete.Definitions: InvalidMeasureMutual :: Range -> DeclarationException

- Agda.Syntax.Concrete.Definitions: InvalidName :: Name -> DeclarationException

- Agda.Syntax.Concrete.Definitions: MissingWithClauses :: Name -> LHS -> DeclarationException

- Agda.Syntax.Concrete.Definitions: MultipleEllipses :: Pattern -> DeclarationException

- Agda.Syntax.Concrete.Definitions: UnquoteDefRequiresSignature :: [Name] -> DeclarationException

- Agda.Syntax.Concrete.Definitions: WrongContentBlock :: KindOfBlock -> Range -> DeclarationException

- Agda.Syntax.Concrete.Definitions: WrongDefinition :: Name -> DataRecOrFun -> DataRecOrFun -> DeclarationException

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakeAbstract Agda.Syntax.Concrete.Definitions.Clause

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakeAbstract Agda.Syntax.Concrete.Definitions.NiceDeclaration

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakePrivate Agda.Syntax.Concrete.Definitions.Clause

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakePrivate Agda.Syntax.Concrete.Definitions.NiceDeclaration

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.DeclarationException

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.DeclarationWarning

- Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.NiceDeclaration

- Agda.Syntax.Concrete.Definitions: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.DeclarationException

- Agda.Syntax.Concrete.Definitions: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.DeclarationWarning

- Agda.Syntax.Concrete.Definitions: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.NiceDeclaration

- Agda.Syntax.Concrete.Definitions: instance Control.Monad.Error.Class.MonadError Agda.Syntax.Concrete.Definitions.DeclarationException Agda.Syntax.Concrete.Definitions.Nice

- Agda.Syntax.Concrete.Definitions: instance Control.Monad.State.Class.MonadState Agda.Syntax.Concrete.Definitions.NiceEnv Agda.Syntax.Concrete.Definitions.Nice

- Agda.Syntax.Concrete.Definitions: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Clause

- Agda.Syntax.Concrete.Definitions: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.DataRecOrFun

- Agda.Syntax.Concrete.Definitions: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.DeclarationException

- Agda.Syntax.Concrete.Definitions: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.DeclarationWarning

- Agda.Syntax.Concrete.Definitions: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.KindOfBlock

- Agda.Syntax.Concrete.Definitions: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.NiceDeclaration

- Agda.Syntax.Concrete.Definitions: instance GHC.Base.Applicative Agda.Syntax.Concrete.Definitions.Nice

- Agda.Syntax.Concrete.Definitions: instance GHC.Base.Functor Agda.Syntax.Concrete.Definitions.Nice

- Agda.Syntax.Concrete.Definitions: instance GHC.Base.Monad Agda.Syntax.Concrete.Definitions.Nice

- Agda.Syntax.Concrete.Definitions: instance GHC.Classes.Eq Agda.Syntax.Concrete.Definitions.DataRecOrFun

- Agda.Syntax.Concrete.Definitions: instance GHC.Classes.Eq Agda.Syntax.Concrete.Definitions.InMutual

- Agda.Syntax.Concrete.Definitions: instance GHC.Classes.Eq Agda.Syntax.Concrete.Definitions.KindOfBlock

- Agda.Syntax.Concrete.Definitions: instance GHC.Classes.Ord Agda.Syntax.Concrete.Definitions.KindOfBlock

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Clause

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.DataRecOrFun

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.DeclarationException

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.DeclarationWarning

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.InMutual

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.KindOfBlock

- Agda.Syntax.Concrete.Definitions: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.NiceDeclaration

- Agda.Syntax.Concrete.Generic: instance (Agda.Syntax.Concrete.Generic.ExprLike qn, Agda.Syntax.Concrete.Generic.ExprLike e) => Agda.Syntax.Concrete.Generic.ExprLike (Agda.Syntax.Common.RewriteEqn' qn p e)

- Agda.Syntax.Concrete.Name: instance Agda.Syntax.Concrete.Name.NumHoles [Agda.Syntax.Concrete.Name.NamePart]

- Agda.Syntax.Concrete.Name: nextStr :: String -> String

- Agda.Syntax.Concrete.Pretty: SpecialCharacters :: (Doc -> Doc) -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> SpecialCharacters

- Agda.Syntax.Concrete.Pretty: [_arrow] :: SpecialCharacters -> Doc

- Agda.Syntax.Concrete.Pretty: [_dbraces] :: SpecialCharacters -> Doc -> Doc

- Agda.Syntax.Concrete.Pretty: [_emptyIdiomBrkt] :: SpecialCharacters -> Doc

- Agda.Syntax.Concrete.Pretty: [_forallQ] :: SpecialCharacters -> Doc

- Agda.Syntax.Concrete.Pretty: [_lambda] :: SpecialCharacters -> Doc

- Agda.Syntax.Concrete.Pretty: [_leftIdiomBrkt] :: SpecialCharacters -> Doc

- Agda.Syntax.Concrete.Pretty: [_rightIdiomBrkt] :: SpecialCharacters -> Doc

- Agda.Syntax.Concrete.Pretty: arrow :: Doc

- Agda.Syntax.Concrete.Pretty: braces' :: Doc -> Doc

- Agda.Syntax.Concrete.Pretty: data SpecialCharacters

- Agda.Syntax.Concrete.Pretty: dbraces :: Doc -> Doc

- Agda.Syntax.Concrete.Pretty: emptyIdiomBrkt :: Doc

- Agda.Syntax.Concrete.Pretty: forallQ :: Doc

- Agda.Syntax.Concrete.Pretty: lambda :: Doc

- Agda.Syntax.Concrete.Pretty: leftIdiomBrkt :: Doc

- Agda.Syntax.Concrete.Pretty: rightIdiomBrkt :: Doc

- Agda.Syntax.Concrete.Pretty: specialCharacters :: SpecialCharacters

- Agda.Syntax.Internal: AbsurdMatch :: NotBlocked

- Agda.Syntax.Internal: Apply :: Arg a -> Elim' a

- Agda.Syntax.Internal: Blocked :: MetaId -> t -> Blocked t

- Agda.Syntax.Internal: BlockedLevel :: MetaId -> t -> LevelAtom' t

- Agda.Syntax.Internal: IApply :: a -> a -> a -> Elim' a

- Agda.Syntax.Internal: MetaLevel :: MetaId -> [Elim' t] -> LevelAtom' t

- Agda.Syntax.Internal: MissingClauses :: NotBlocked

- Agda.Syntax.Internal: NeutralLevel :: NotBlocked -> t -> LevelAtom' t

- Agda.Syntax.Internal: NotBlocked :: NotBlocked -> t -> Blocked t

- Agda.Syntax.Internal: Proj :: ProjOrigin -> QName -> Elim' a

- Agda.Syntax.Internal: ReallyNotBlocked :: NotBlocked

- Agda.Syntax.Internal: StuckOn :: Elim -> NotBlocked

- Agda.Syntax.Internal: Underapplied :: NotBlocked

- Agda.Syntax.Internal: UnreducedLevel :: t -> LevelAtom' t

- Agda.Syntax.Internal: [blockingStatus] :: Blocked t -> NotBlocked

- Agda.Syntax.Internal: [ignoreBlocking] :: Blocked t -> t

- Agda.Syntax.Internal: [theBlockingMeta] :: Blocked t -> MetaId

- Agda.Syntax.Internal: allApplyElims :: [Elim' a] -> Maybe [Arg a]

- Agda.Syntax.Internal: allProjElims :: Elims -> Maybe [(ProjOrigin, QName)]

- Agda.Syntax.Internal: argsFromElims :: Elims -> Args

- Agda.Syntax.Internal: blocked :: MetaId -> a -> Blocked a

- Agda.Syntax.Internal: blocked_ :: MetaId -> Blocked_

- Agda.Syntax.Internal: blockingMeta :: Blocked t -> Maybe MetaId

- Agda.Syntax.Internal: class IsProjElim e

- Agda.Syntax.Internal: data Blocked t

- Agda.Syntax.Internal: data Elim' a

- Agda.Syntax.Internal: data LevelAtom' t

- Agda.Syntax.Internal: data NotBlocked

- Agda.Syntax.Internal: dummyLevel' :: String -> Int -> Level

- Agda.Syntax.Internal: dummyTerm' :: String -> Int -> Term

- Agda.Syntax.Internal: instance Agda.Syntax.Common.LensNamed Agda.Syntax.Common.NamedName (Agda.Syntax.Internal.Dom' t e)

- Agda.Syntax.Internal: instance Agda.Syntax.Common.LensOrigin (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal: instance Agda.Syntax.Internal.IsProjElim (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal: instance Agda.Syntax.Internal.PatternVars a (Agda.Syntax.Common.Arg (Agda.Syntax.Internal.Pattern' a))

- Agda.Syntax.Internal: instance Agda.Syntax.Internal.PatternVars a (Agda.Syntax.Common.NamedArg (Agda.Syntax.Internal.Pattern' a))

- Agda.Syntax.Internal: instance Agda.Syntax.Internal.PatternVars a b => Agda.Syntax.Internal.PatternVars a [b]

- Agda.Syntax.Internal: instance Agda.Syntax.Internal.TermSize Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal: instance Agda.Utils.Pretty.Pretty tm => Agda.Utils.Pretty.Pretty (Agda.Syntax.Internal.Elim' tm)

- Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.NotBlocked

- Agda.Syntax.Internal: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Internal.Substitution' a)

- Agda.Syntax.Internal: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.Blocked t)

- Agda.Syntax.Internal: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.LevelAtom' t)

- Agda.Syntax.Internal: instance Data.Foldable.Foldable Agda.Syntax.Internal.Blocked

- Agda.Syntax.Internal: instance Data.Foldable.Foldable Agda.Syntax.Internal.Elim'

- Agda.Syntax.Internal: instance Data.Traversable.Traversable Agda.Syntax.Internal.Blocked

- Agda.Syntax.Internal: instance Data.Traversable.Traversable Agda.Syntax.Internal.Elim'

- Agda.Syntax.Internal: instance GHC.Base.Applicative Agda.Syntax.Internal.Blocked

- Agda.Syntax.Internal: instance GHC.Base.Functor Agda.Syntax.Internal.Blocked

- Agda.Syntax.Internal: instance GHC.Base.Functor Agda.Syntax.Internal.Elim'

- Agda.Syntax.Internal: instance GHC.Base.Monoid Agda.Syntax.Internal.Blocked_

- Agda.Syntax.Internal: instance GHC.Base.Monoid Agda.Syntax.Internal.NotBlocked

- Agda.Syntax.Internal: instance GHC.Base.Semigroup Agda.Syntax.Internal.Blocked_

- Agda.Syntax.Internal: instance GHC.Base.Semigroup Agda.Syntax.Internal.NotBlocked

- Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.NotBlocked

- Agda.Syntax.Internal: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.Blocked t)

- Agda.Syntax.Internal: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.LevelAtom' t)

- Agda.Syntax.Internal: isApplyElim :: Elim' a -> Maybe (Arg a)

- Agda.Syntax.Internal: isApplyElim' :: Empty -> Elim' a -> Arg a

- Agda.Syntax.Internal: isProjElim :: IsProjElim e => e -> Maybe (ProjOrigin, QName)

- Agda.Syntax.Internal: notBlocked :: a -> Blocked a

- Agda.Syntax.Internal: notBlocked_ :: Blocked_

- Agda.Syntax.Internal: sort :: Sort -> Type

- Agda.Syntax.Internal: splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])

- Agda.Syntax.Internal: stuckOn :: Elim -> NotBlocked -> NotBlocked

- Agda.Syntax.Internal: topSort :: Type

- Agda.Syntax.Internal: unreducedLevel :: Term -> Level

- Agda.Syntax.Internal.Defs: instance Agda.Syntax.Internal.Defs.GetDefs Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal.Defs: instance Agda.Syntax.Internal.Defs.GetDefs a => Agda.Syntax.Internal.Defs.GetDefs (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.Generic.TermLike (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Internal.LevelAtom

- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Elim' a)

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars Agda.Syntax.Internal.Pattern Agda.Syntax.Internal.DeBruijnPattern GHC.Types.Int

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars a b i => Agda.Syntax.Internal.Pattern.LabelPatVars (Agda.Syntax.Common.Arg a) (Agda.Syntax.Common.Arg b) i

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars a b i => Agda.Syntax.Internal.Pattern.LabelPatVars (Agda.Syntax.Common.Named x a) (Agda.Syntax.Common.Named x b) i

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars a b i => Agda.Syntax.Internal.Pattern.LabelPatVars [a] [b] i

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities (Agda.Syntax.Internal.Pattern' x) x

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities a x => Agda.Syntax.Internal.Pattern.PatternVarModalities (Agda.Syntax.Common.Arg a) x

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities a x => Agda.Syntax.Internal.Pattern.PatternVarModalities (Agda.Syntax.Common.Named s a) x

- Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities a x => Agda.Syntax.Internal.Pattern.PatternVarModalities [a] x

- Agda.Syntax.Literal: compareFloat :: Double -> Double -> Ordering

- Agda.Syntax.Literal: instance Agda.Syntax.Position.HasRange Agda.Syntax.Literal.Literal

- Agda.Syntax.Literal: instance Agda.Syntax.Position.SetRange Agda.Syntax.Literal.Literal

- Agda.Syntax.Literal: showString' :: String -> ShowS

- Agda.Syntax.Parser.Alex: type LexAction r = PreviousInput -> CurrentInput -> TokenLength -> Parser r

- Agda.Syntax.Parser.Layout: closeBrace :: LexAction Token

- Agda.Syntax.Parser.Layout: newLayoutContext :: LexAction Token

- Agda.Syntax.Parser.Layout: openBrace :: LexAction Token

- Agda.Syntax.Parser.Monad: NoLayout :: LayoutContext

- Agda.Syntax.Parser.Monad: data LayoutContext

- Agda.Syntax.Parser.Monad: instance GHC.Show.Show Agda.Syntax.Parser.Monad.LayoutContext

- Agda.Syntax.Parser.Monad: popContext :: Parser ()

- Agda.Syntax.Parser.Monad: pushContext :: LayoutContext -> Parser ()

- Agda.Syntax.Parser.Monad: pushCurrentContext :: Parser ()

- Agda.Syntax.Parser.Monad: topContext :: Parser LayoutContext

- Agda.Syntax.Parser.Parser: instance GHC.Classes.Eq Agda.Syntax.Parser.Parser.RecordDirective

- Agda.Syntax.Parser.Parser: instance GHC.Show.Show Agda.Syntax.Parser.Parser.RecordDirective

- Agda.Syntax.Parser.Tokens: KwProp :: Keyword

- Agda.Syntax.Parser.Tokens: KwSet :: Keyword

- Agda.Syntax.Parser.Tokens: TokPropN :: (Interval, Integer) -> Token

- Agda.Syntax.Parser.Tokens: TokSetN :: (Interval, Integer) -> Token

- Agda.Syntax.Position: instance Agda.Syntax.Position.HasRange a => Agda.Syntax.Position.HasRange (GHC.Base.NonEmpty a)

- Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (GHC.Base.NonEmpty a)

- Agda.Syntax.Position: instance GHC.Show.Show Agda.Syntax.Position.IntervalWithoutFile

- Agda.Syntax.Position: instance GHC.Show.Show Agda.Syntax.Position.PositionWithoutFile

- Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Interval' (Data.Strict.Maybe.Maybe a))

- Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Position' (Data.Strict.Maybe.Maybe a))

- Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Range' (Data.Strict.Maybe.Maybe a))

- Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Range' (GHC.Maybe.Maybe a))

- Agda.Syntax.Scope.Base: inverseScopeLookup :: Either ModuleName QName -> ScopeInfo -> [QName]

- Agda.Syntax.Scope.Base: inverseScopeLookup' :: AllowAmbiguousNames -> Either ModuleName QName -> ScopeInfo -> [QName]

- Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a1 c1, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a2 c2) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Data.Either.Either a1 a2) (Data.Either.Either c1 c2)

- Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a1 c1, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a2 c2, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a3 c3) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (a1, a2, a3) (c1, c2, c3)

- Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete p q, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a b) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Common.RewriteEqn' qn p a) (Agda.Syntax.Common.RewriteEqn' () q b)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete () ()

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Common.Constr Agda.Syntax.Abstract.Constructor) Agda.Syntax.Concrete.Declaration

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.SplitPattern (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern)) (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.SplitPattern Agda.Syntax.Abstract.Pattern) Agda.Syntax.Abstract.Pattern

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.UserPattern (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern)) (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.UserPattern Agda.Syntax.Abstract.Pattern) Agda.Syntax.Abstract.Pattern

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (GHC.Maybe.Maybe Agda.Syntax.Abstract.Name.QName) (GHC.Maybe.Maybe Agda.Syntax.Concrete.Name.Name)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (GHC.Maybe.Maybe Agda.Syntax.Abstract.Pattern) (GHC.Maybe.Maybe Agda.Syntax.Concrete.Pattern)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.BindName Agda.Syntax.Concrete.BoundName

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Declaration [Agda.Syntax.Concrete.Declaration]

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Expr Agda.Syntax.Concrete.Expr

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LHS Agda.Syntax.Concrete.LHS

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LHSCore Agda.Syntax.Concrete.Pattern

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LamBinding Agda.Syntax.Concrete.LamBinding

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LetBinding [Agda.Syntax.Concrete.Declaration]

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.ModuleApplication Agda.Syntax.Concrete.ModuleApplication

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.ModuleName Agda.Syntax.Concrete.Name.QName

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.Name Agda.Syntax.Concrete.Name.Name

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.QName Agda.Syntax.Concrete.Name.QName

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Pattern Agda.Syntax.Concrete.Pattern

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.RHS (Agda.Syntax.Concrete.RHS, [Agda.Syntax.Concrete.RewriteEqn], [Agda.Syntax.Common.WithHiding Agda.Syntax.Concrete.Expr], [Agda.Syntax.Concrete.Declaration])

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.SpineLHS Agda.Syntax.Concrete.LHS

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.TypedBinding Agda.Syntax.Concrete.TypedBinding

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.WhereDeclarations Agda.Syntax.Concrete.WhereClause

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Common.InteractionId Agda.Syntax.Concrete.Expr

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Scope.Base.AbstractName Agda.Syntax.Concrete.Name.QName

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Scope.Base.ResolvedName Agda.Syntax.Concrete.Name.QName

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Translation.AbstractToConcrete.BindingPattern Agda.Syntax.Abstract.Pattern

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Translation.AbstractToConcrete.FreshenName Agda.Syntax.Abstract.Name.Name

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Translation.AbstractToConcrete.RangeAndPragma Agda.Syntax.Concrete.Pragma

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.TypeChecking.Monad.Base.NamedMeta Agda.Syntax.Concrete.Expr

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete GHC.Types.Bool GHC.Types.Bool

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a Agda.Syntax.Concrete.LHS => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Abstract.Clause' a) [Agda.Syntax.Concrete.Declaration]

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a b => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Abstract.Binder' a) (Agda.Syntax.Concrete.Binder' b)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a c => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Common.Arg a) (Agda.Syntax.Common.Arg c)

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a c => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete [a] [c]

- Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Base.HasOptions Agda.Syntax.Translation.AbstractToConcrete.AbsToCon

- Agda.Syntax.Translation.ConcreteToAbstract: OldName :: a -> OldName a

- Agda.Syntax.Translation.ConcreteToAbstract: instance (Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c1 a1, Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c2 a2) => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Data.Either.Either c1 c2) (Data.Either.Either a1 a2)

- Agda.Syntax.Translation.ConcreteToAbstract: instance (Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c1 a1, Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c2 a2, Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c3 a3) => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (c1, c2, c3) (a1, a2, a3)

- Agda.Syntax.Translation.ConcreteToAbstract: instance (GHC.Show.Show a, Agda.Syntax.Translation.ConcreteToAbstract.ToQName a) => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.OldName a) Agda.Syntax.Abstract.Name.QName

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract () ()

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Abstract.LHSCore' Agda.Syntax.Concrete.Expr) (Agda.Syntax.Abstract.LHSCore' Agda.Syntax.Abstract.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Abstract.Pattern' Agda.Syntax.Concrete.Expr) (Agda.Syntax.Abstract.Pattern' Agda.Syntax.Abstract.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Common.RewriteEqn' () Agda.Syntax.Abstract.Pattern Agda.Syntax.Abstract.Expr) Agda.Syntax.Abstract.RewriteEqn

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Concrete.Binder' (Agda.Syntax.Translation.ConcreteToAbstract.NewName Agda.Syntax.Concrete.BoundName)) Agda.Syntax.Abstract.Binder

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.NewName Agda.Syntax.Concrete.BoundName) Agda.Syntax.Abstract.BindName

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.TopLevel [Agda.Syntax.Concrete.Declaration]) Agda.Syntax.Translation.ConcreteToAbstract.TopLevelInfo

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Definitions.Clause Agda.Syntax.Abstract.Clause

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Definitions.NiceDeclaration Agda.Syntax.Abstract.Declaration

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Expr Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.HoleContent Agda.Syntax.Abstract.HoleContent

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.LHSCore (Agda.Syntax.Abstract.LHSCore' Agda.Syntax.Concrete.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.LamBinding Agda.Syntax.Abstract.LamBinding

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.ModuleAssignment (Agda.Syntax.Abstract.Name.ModuleName, [Agda.Syntax.Abstract.LetBinding])

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Pattern (Agda.Syntax.Abstract.Pattern' Agda.Syntax.Concrete.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Pragma [Agda.Syntax.Abstract.Pragma]

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.RHS Agda.Syntax.Translation.ConcreteToAbstract.AbstractRHS

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.RewriteEqn (Agda.Syntax.Common.RewriteEqn' () Agda.Syntax.Abstract.Pattern Agda.Syntax.Abstract.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.TypedBinding Agda.Syntax.Abstract.TypedBinding

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.AbstractRHS Agda.Syntax.Abstract.RHS

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.ConstrDecl Agda.Syntax.Abstract.Declaration

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.GenTel Agda.Syntax.Abstract.GeneralizeTelescope

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.GenTelAndType (Agda.Syntax.Abstract.GeneralizeTelescope, Agda.Syntax.Abstract.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LeftHandSide Agda.Syntax.Abstract.LHS

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LetDef [Agda.Syntax.Abstract.LetBinding]

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LetDefs [Agda.Syntax.Abstract.LetBinding]

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.MaybeOldQName (GHC.Maybe.Maybe Agda.Syntax.Abstract.Expr)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.NewModuleName Agda.Syntax.Abstract.Name.ModuleName

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.OldModuleName Agda.Syntax.Abstract.Name.ModuleName

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.OldQName Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.PatName Agda.Syntax.Translation.ConcreteToAbstract.APatName

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.RecordConstructorType Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.ResolveQName Agda.Syntax.Scope.Base.ResolvedName

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.RightHandSide Agda.Syntax.Translation.ConcreteToAbstract.AbstractRHS

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract [Agda.Syntax.Concrete.Declaration] [Agda.Syntax.Abstract.Declaration]

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c a => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Common.Arg c) (Agda.Syntax.Common.Arg a)

- Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c a => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract [c] [a]

- Agda.Syntax.Translation.ConcreteToAbstract: newtype OldName a

- Agda.Syntax.Translation.InternalToAbstract: instance (Agda.Syntax.Translation.InternalToAbstract.Reify i1 a1, Agda.Syntax.Translation.InternalToAbstract.Reify i2 a2, Agda.Syntax.Translation.InternalToAbstract.Reify i3 a3) => Agda.Syntax.Translation.InternalToAbstract.Reify (i1, i2, i3) (a1, a2, a3)

- Agda.Syntax.Translation.InternalToAbstract: instance (Agda.Syntax.Translation.InternalToAbstract.Reify i1 a1, Agda.Syntax.Translation.InternalToAbstract.Reify i2 a2, Agda.Syntax.Translation.InternalToAbstract.Reify i3 a3, Agda.Syntax.Translation.InternalToAbstract.Reify i4 a4) => Agda.Syntax.Translation.InternalToAbstract.Reify (i1, i2, i3, i4) (a1, a2, a3, a4)

- Agda.Syntax.Translation.InternalToAbstract: instance (Agda.TypeChecking.Free.Lazy.Free i, Agda.Syntax.Translation.InternalToAbstract.Reify i a) => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Internal.Abs i) (Agda.Syntax.Abstract.Name.Name, a)

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Internal.Clause) Agda.Syntax.Abstract.Clause

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Abstract.Name.QNamed Agda.TypeChecking.Monad.Base.System) [Agda.Syntax.Abstract.Clause]

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Abstract.Expr Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Abstract.Name.Name Agda.Syntax.Abstract.Name.Name

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Common.MetaId Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Level Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Sort Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Telescope Agda.Syntax.Abstract.Telescope

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Term Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Type Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Literal.Literal Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Translation.InternalToAbstract.NamedClause Agda.Syntax.Abstract.Clause

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.DisplayTerm Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify GHC.Types.Bool GHC.Types.Bool

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i a => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Common.Arg i) (Agda.Syntax.Common.Arg a)

- Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i a => Agda.Syntax.Translation.InternalToAbstract.Reify [i] [a]

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Abstract.Expr, Agda.Syntax.Reflected.Elim) Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Abstract.Expr, Agda.Syntax.Reflected.Elims) Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Reflected.Clause) Agda.Syntax.Abstract.Clause

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Literal.Literal Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Reflected.Pattern (Agda.Syntax.Translation.ReflectedToAbstract.Names, Agda.Syntax.Abstract.Pattern)

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Reflected.Sort Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Reflected.Term Agda.Syntax.Abstract.Expr

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract [Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Reflected.Clause] [Agda.Syntax.Abstract.Clause]

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract [Agda.Syntax.Common.Arg Agda.Syntax.Reflected.Term] [Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Expr]

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract r Agda.Syntax.Abstract.Expr => Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Internal.Dom r, Agda.Syntax.Abstract.Name.Name) Agda.Syntax.Abstract.TypedBinding

- Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract r a => Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Common.Arg r) (Agda.Syntax.Common.NamedArg a)

- Agda.Syntax.Translation.ReflectedToAbstract: mkSet :: Expr -> Expr

- Agda.Syntax.Translation.ReflectedToAbstract: toAbstractPats :: MonadReflectedToAbstract m => [Arg Pattern] -> m (Names, [NamedArg Pattern])

- Agda.Syntax.Translation.ReflectedToAbstract: type Names = [Name]

- Agda.Termination.Monad: instance Agda.Syntax.Abstract.AllNames Agda.Termination.Monad.CallPath

- Agda.Termination.Monad: instance Agda.TypeChecking.Monad.Base.HasOptions Agda.Termination.Monad.TerM

- Agda.Termination.Monad: instance Agda.Utils.Benchmark.MonadBench Agda.Benchmarking.Phase Agda.Termination.Monad.TerM

- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.ExtractCalls Agda.Syntax.Internal.LevelAtom

- Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.ExtractCalls a => Agda.Termination.TermCheck.ExtractCalls (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Abstract: instance (Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term a, Agda.TypeChecking.Abstract.AbsTerm a) => Agda.TypeChecking.Abstract.AbsTerm (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Abstract: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Abstract.EqualSy a) => Agda.TypeChecking.Abstract.EqualSy (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.AbsTerm Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.AbsTerm a => Agda.TypeChecking.Abstract.AbsTerm (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.EqualSy Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.EqualSy a => Agda.TypeChecking.Abstract.EqualSy (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.CheckInternal: [relevanceAction] :: Action m -> Relevance -> Relevance -> Relevance

- Agda.TypeChecking.CheckInternal: inferSort :: MonadCheckInternal m => Term -> m Sort

- Agda.TypeChecking.CompiledClause: prettyMap :: (Pretty k, Pretty v) => Map k v -> [Doc]

- Agda.TypeChecking.Constraints: catchPatternErrTCM :: TCM a -> TCM a -> TCM a

- Agda.TypeChecking.Conversion: compareTel :: MonadConversion m => Type -> Type -> Comparison -> Telescope -> Telescope -> m ()

- Agda.TypeChecking.Conversion: equalLevel' :: forall m. MonadConversion m => Level -> Level -> m ()

- Agda.TypeChecking.Conversion.Pure: instance (Agda.TypeChecking.Monad.Base.MonadReduce m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Builtin.HasBuiltins m) => Agda.TypeChecking.Warnings.MonadWarning (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

- Agda.TypeChecking.Conversion.Pure: instance (Agda.TypeChecking.Monad.Base.MonadTCEnv m, Agda.TypeChecking.Monad.Base.MonadReduce m, Agda.TypeChecking.Monad.Context.MonadAddContext m, Agda.TypeChecking.Monad.Base.ReadTCState m, Agda.TypeChecking.Monad.Builtin.HasBuiltins m, Agda.TypeChecking.Monad.Signature.HasConstInfo m, Agda.TypeChecking.Monad.Debug.MonadDebug m) => Agda.TypeChecking.Monad.MetaVars.MonadMetaSolver (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

- Agda.TypeChecking.Conversion.Pure: instance (Agda.TypeChecking.Monad.Base.MonadTCEnv m, Agda.TypeChecking.Monad.Base.ReadTCState m) => Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

- Agda.TypeChecking.Conversion.Pure: instance (Agda.TypeChecking.Monad.Base.MonadTCEnv m, Agda.TypeChecking.Monad.Base.ReadTCState m, Agda.TypeChecking.Monad.Base.HasOptions m, Agda.TypeChecking.Monad.Debug.MonadDebug m) => Agda.TypeChecking.Monad.Constraints.MonadConstraint (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

- Agda.TypeChecking.Conversion.Pure: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

- Agda.TypeChecking.Conversion.Pure: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadFresh Agda.TypeChecking.Monad.Base.ProblemId (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

- Agda.TypeChecking.Coverage.Match: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Coverage.Match.SplitPattern Agda.TypeChecking.Coverage.Match.SplitPattern

- Agda.TypeChecking.Datatypes: getConHeads :: QName -> TCM [ConHead]

- Agda.TypeChecking.Datatypes: getConHeads' :: QName -> TCM (Maybe [ConHead])

- Agda.TypeChecking.Datatypes: makeConHead :: QName -> TCM ConHead

- Agda.TypeChecking.DisplayForm: class Match a

- Agda.TypeChecking.DisplayForm: class SubstWithOrigin a

- Agda.TypeChecking.DisplayForm: displayFormArities :: (HasConstInfo m, ReadTCState m) => QName -> m [Int]

- Agda.TypeChecking.DisplayForm: dtermToTerm :: DisplayTerm -> Term

- Agda.TypeChecking.DisplayForm: instance (Agda.TypeChecking.DisplayForm.SubstWithOrigin a, Agda.TypeChecking.DisplayForm.SubstWithOrigin (Agda.Syntax.Common.Arg a)) => Agda.TypeChecking.DisplayForm.SubstWithOrigin (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.DisplayForm: instance Agda.TypeChecking.DisplayForm.Match a => Agda.TypeChecking.DisplayForm.Match (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.DisplayForm: match :: (Match a, MonadDisplayForm m) => a -> a -> MaybeT m [WithOrigin Term]

- Agda.TypeChecking.DisplayForm: matchDisplayForm :: MonadDisplayForm m => DisplayForm -> Elims -> MaybeT m (DisplayForm, DisplayTerm)

- Agda.TypeChecking.DisplayForm: substWithOrigin :: SubstWithOrigin a => Substitution -> [WithOrigin Term] -> a -> a

- Agda.TypeChecking.DisplayForm: type MonadDisplayForm m = (MonadReduce m, ReadTCState m, HasConstInfo m, HasBuiltins m, MonadDebug m)

- Agda.TypeChecking.Errors: applyFlagsToTCWarnings' :: MainInterface -> [TCWarning] -> TCM [TCWarning]

- Agda.TypeChecking.Errors: prettyWarning :: MonadPretty m => Warning -> m Doc

- Agda.TypeChecking.Forcing: instance Agda.TypeChecking.Forcing.ForcedVariables a => Agda.TypeChecking.Forcing.ForcedVariables (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Free.Lazy: instance (GHC.Base.Applicative m, GHC.Base.Semigroup c) => GHC.Base.Semigroup (Agda.TypeChecking.Free.Lazy.FreeT a b m c)

- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free Agda.Syntax.Internal.PlusLevel

- Agda.TypeChecking.Free.Lazy: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.Syntax.Internal.Elim' t)

- Agda.TypeChecking.Free.Precompute: instance Agda.TypeChecking.Free.Precompute.PrecomputeFreeVars Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Free.Precompute: instance Agda.TypeChecking.Free.Precompute.PrecomputeFreeVars a => Agda.TypeChecking.Free.Precompute.PrecomputeFreeVars (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Free.Reduce: instance (Agda.TypeChecking.Reduce.Reduce a, Agda.TypeChecking.Free.Reduce.ForceNotFree a) => Agda.TypeChecking.Free.Reduce.ForceNotFree (Agda.Syntax.Internal.Dom a)

- Agda.TypeChecking.Free.Reduce: instance (Agda.TypeChecking.Reduce.Reduce a, Agda.TypeChecking.Free.Reduce.ForceNotFree a) => Agda.TypeChecking.Free.Reduce.ForceNotFree (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Free.Reduce: instance Agda.TypeChecking.Free.Reduce.ForceNotFree Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Irrelevance: applyQuantityToContextOnly :: MonadTCEnv tcm => Quantity -> tcm a -> tcm a

- Agda.TypeChecking.Irrelevance: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Irrelevance.UsableModality a) => Agda.TypeChecking.Irrelevance.UsableModality (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Irrelevance: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Irrelevance.UsableRelevance a) => Agda.TypeChecking.Irrelevance.UsableRelevance (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Irrelevance: instance Agda.TypeChecking.Irrelevance.UsableModality a => Agda.TypeChecking.Irrelevance.UsableModality (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Irrelevance: instance Agda.TypeChecking.Irrelevance.UsableRelevance Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Irrelevance: instance Agda.TypeChecking.Irrelevance.UsableRelevance a => Agda.TypeChecking.Irrelevance.UsableRelevance (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Level: data SingleLevel

- Agda.TypeChecking.Level: instance Agda.TypeChecking.Free.Lazy.Free Agda.TypeChecking.Level.SingleLevel

- Agda.TypeChecking.Level: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Level.SingleLevel

- Agda.TypeChecking.Level: instance GHC.Show.Show Agda.TypeChecking.Level.SingleLevel

- Agda.TypeChecking.MetaVars: ProjVarExc :: Int -> [(ProjOrigin, QName)] -> ProjVarExc

- Agda.TypeChecking.MetaVars: ProjectedVar :: Int -> [(ProjOrigin, QName)] -> InvertExcept

- Agda.TypeChecking.MetaVars: data ProjVarExc

- Agda.TypeChecking.MetaVars.Mention: instance Agda.TypeChecking.MetaVars.Mention.MentionsMeta Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.MetaVars.Occurs: instance (Agda.TypeChecking.MetaVars.Occurs.Occurs a, Agda.TypeChecking.Substitute.Class.Subst t a) => Agda.TypeChecking.MetaVars.Occurs.Occurs (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.MetaVars.Occurs: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.MetaVars.Occurs.AnyRigid a) => Agda.TypeChecking.MetaVars.Occurs.AnyRigid (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.AnyRigid Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.AnyRigid a => Agda.TypeChecking.MetaVars.Occurs.AnyRigid (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.Occurs Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.Occurs a => Agda.TypeChecking.MetaVars.Occurs.Occurs (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Monad.Base: Guarded :: Constraint -> ProblemId -> Constraint

- Agda.TypeChecking.Monad.Base: IlltypedPattern :: Pattern -> Type -> TypeError

- Agda.TypeChecking.Monad.Base: IrrelevantDatatype :: Closure Type -> SplitError

- Agda.TypeChecking.Monad.Base: ProblemId :: Nat -> ProblemId

- Agda.TypeChecking.Monad.Base: TelCmp :: Type -> Type -> Comparison -> Telescope -> Telescope -> Constraint

- Agda.TypeChecking.Monad.Base: YesGeneralize :: DoGeneralize

- Agda.TypeChecking.Monad.Base: [dfFreeVars] :: DisplayForm -> Nat

- Agda.TypeChecking.Monad.Base: [envCheckOptionConsistency] :: TCEnv -> Bool

- Agda.TypeChecking.Monad.Base: [envModuleNestingLevel] :: TCEnv -> !Int

- Agda.TypeChecking.Monad.Base: [iPragmaOptions] :: Interface -> [OptionsPragma]

- Agda.TypeChecking.Monad.Base: eModuleNestingLevel :: Lens' Int TCEnv

- Agda.TypeChecking.Monad.Base: getIncludeDirs :: HasOptions m => m [AbsolutePath]

- Agda.TypeChecking.Monad.Base: instance (Agda.TypeChecking.Monad.Base.HasOptions m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Base.HasOptions (Control.Monad.Trans.Writer.Lazy.WriterT w m)

- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Abstract.AllNames Agda.TypeChecking.Monad.Base.CallInfo

- Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.IsProjElim e => Agda.Syntax.Internal.IsProjElim (Agda.TypeChecking.Monad.Base.MaybeReduced e)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasFresh Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions Agda.TypeChecking.Monad.Base.ReduceM

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Agda.Utils.ListT.ListT m)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Agda.Utils.Update.ChangeT m)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Control.Monad.Trans.Except.ExceptT e m)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Control.Monad.Trans.Identity.IdentityT m)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Control.Monad.Trans.Maybe.MaybeT m)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Control.Monad.Trans.Reader.ReaderT r m)

- Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Control.Monad.Trans.State.Lazy.StateT s m)

- Agda.TypeChecking.Monad.Base: instance Agda.Utils.Benchmark.MonadBench Agda.Benchmarking.Phase Agda.TypeChecking.Monad.Base.TCM

- Agda.TypeChecking.Monad.Base: instance Agda.Utils.Except.Error Agda.TypeChecking.Monad.Base.TCErr

- Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance Control.Monad.Error.Class.MonadError Agda.TypeChecking.Monad.Base.TCErr Agda.TypeChecking.Monad.Base.IM

- Agda.TypeChecking.Monad.Base: instance Control.Monad.IO.Class.MonadIO m => Agda.TypeChecking.Monad.Base.HasOptions (Agda.TypeChecking.Monad.Base.TCMT m)

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CallInfo

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Constraint

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Definition

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.IPClause

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ProblemConstraint

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Signature

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.TCEnv

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.TerminationError

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Warning

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data a => Data.Data.Data (Agda.TypeChecking.Monad.Base.Closure a)

- Agda.TypeChecking.Monad.Base: instance Data.Data.Data a => Data.Data.Data (Agda.TypeChecking.Monad.Base.Open a)

- Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Classes.Ord Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Enum.Enum Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Num.Num Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Real.Integral Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Real.Real Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Monad.Base.Judgement a)

- Agda.TypeChecking.Monad.Base: newtype ProblemId

- Agda.TypeChecking.Monad.Base: runIM :: IM a -> TCM a

- Agda.TypeChecking.Monad.Base: type IM = TCMT (InputT IO)

- Agda.TypeChecking.Monad.Constraints: catchPatternErr :: MonadConstraint m => m a -> m a -> m a

- Agda.TypeChecking.Monad.Env: withIncreasedModuleNestingLevel :: TCM a -> TCM a

- Agda.TypeChecking.Monad.Env: withoutOptionsChecking :: TCM a -> TCM a

- Agda.TypeChecking.Monad.Imports: isVisited :: TopLevelModuleName -> TCM Bool

- Agda.TypeChecking.Monad.Imports: mapVisitedModule :: TopLevelModuleName -> (ModuleInfo -> ModuleInfo) -> TCM ()

- Agda.TypeChecking.Monad.MetaVars: instance Agda.TypeChecking.Monad.MetaVars.IsInstantiatedMeta Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Monad.MetaVars: instance Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints m => Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints (Control.Monad.Trans.State.Lazy.StateT r m)

- Agda.TypeChecking.Monad.MetaVars: instance Agda.TypeChecking.Monad.MetaVars.UnFreezeMeta Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Monad.MetaVars: setMetaArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m ()

- Agda.TypeChecking.Monad.Options: getInputFile :: TCM AbsolutePath

- Agda.TypeChecking.Monad.Options: getInputFile' :: TCM (Maybe AbsolutePath)

- Agda.TypeChecking.Monad.Options: hasInputFile :: HasOptions m => m Bool

- Agda.TypeChecking.Monad.Options: ignoreAllInterfaces :: HasOptions m => m Bool

- Agda.TypeChecking.Monad.Options: ignoreInterfaces :: HasOptions m => m Bool

- Agda.TypeChecking.Monad.Options: setInputFile :: FilePath -> TCM ()

- Agda.TypeChecking.Names: instance Agda.TypeChecking.Monad.Base.HasOptions m => Agda.TypeChecking.Monad.Base.HasOptions (Agda.TypeChecking.Names.NamesT m)

- Agda.TypeChecking.Polarity: (/\) :: Polarity -> Polarity -> Polarity

- Agda.TypeChecking.Polarity: checkSizeIndex :: QName -> Nat -> Type -> TCM Bool

- Agda.TypeChecking.Polarity: class HasPolarity a

- Agda.TypeChecking.Polarity: dependentPolarity :: Type -> [Polarity] -> [Polarity] -> TCM [Polarity]

- Agda.TypeChecking.Polarity: enablePhantomTypes :: Defn -> [Polarity] -> [Polarity]

- Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity Agda.Syntax.Internal.Level

- Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity Agda.Syntax.Internal.PlusLevel

- Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity Agda.Syntax.Internal.Type

- Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity a => Agda.TypeChecking.Polarity.HasPolarity (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Polarity: neg :: Polarity -> Polarity

- Agda.TypeChecking.Polarity: polarities :: HasPolarity a => Nat -> a -> TCM [Polarity]

- Agda.TypeChecking.Polarity: polarity :: HasPolarity a => Nat -> a -> TCM Polarity

- Agda.TypeChecking.Polarity: polarityFromPositivity :: QName -> TCM ()

- Agda.TypeChecking.Polarity: relevantInIgnoringNonvariant :: Nat -> Type -> [Polarity] -> TCM Bool

- Agda.TypeChecking.Polarity: sizePolarity :: QName -> [Polarity] -> TCM [Polarity]

- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Positivity.ComputeOccurrences a => Agda.TypeChecking.Positivity.ComputeOccurrences (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Positivity: instance Agda.TypeChecking.Pretty.PrettyTCM n => Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Pretty.WithNode n (Agda.TypeChecking.Positivity.Edge Agda.TypeChecking.Positivity.Occurrence.OccursWhere))

- Agda.TypeChecking.Positivity: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.TypeChecking.Positivity.OccM a)

- Agda.TypeChecking.Pretty: instance (Agda.Syntax.Translation.InternalToAbstract.Reify a e, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete e c, Agda.Utils.Pretty.Pretty c) => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.Arg a)

- Agda.TypeChecking.Pretty: instance (Agda.TypeChecking.Pretty.PrettyTCM n, Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Pretty.WithNode n e)) => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Utils.Graph.AdjacencyMap.Unidirectional.Graph n e)

- Agda.TypeChecking.Pretty: instance (Agda.Utils.Pretty.Pretty a, Agda.TypeChecking.Pretty.PrettyTCM a, Agda.TypeChecking.Substitute.Class.Subst a a) => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Substitution' a)

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Elim' Agda.TypeChecking.Monad.Base.DisplayTerm)

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Elim' Agda.TypeChecking.Monad.Base.NLPat)

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Common.ArgName

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.Constraint

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.ProblemConstraint

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.ProblemId

- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM n => Agda.TypeChecking.Pretty.PrettyTCM (Agda.TypeChecking.Pretty.WithNode n Agda.TypeChecking.Positivity.Occurrence.Occurrence)

- Agda.TypeChecking.Pretty.Warning: applyFlagsToTCWarnings' :: MainInterface -> [TCWarning] -> TCM [TCWarning]

- Agda.TypeChecking.Pretty.Warning: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.Warning

- Agda.TypeChecking.Pretty.Warning: interestingConstraint :: ProblemConstraint -> Bool

- Agda.TypeChecking.Pretty.Warning: prettyConstraint :: MonadPretty m => ProblemConstraint -> m Doc

- Agda.TypeChecking.Pretty.Warning: prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]

- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.FromTerm Agda.Utils.String.Str

- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm Agda.Utils.String.Str

- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm a => Agda.TypeChecking.Primitive.PrimType a

- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.ToTerm Agda.Utils.String.Str

- Agda.TypeChecking.Primitive: instance GHC.Show.Show Agda.TypeChecking.Primitive.Lvl

- Agda.TypeChecking.Primitive: instance GHC.Show.Show Agda.TypeChecking.Primitive.Nat

- Agda.TypeChecking.Quote: [quoteClauseWithKit] :: QuotingKit -> Clause -> ReduceM Term

- Agda.TypeChecking.RecordPatterns: instance Agda.TypeChecking.Monad.Base.HasOptions Agda.TypeChecking.RecordPatterns.RecPatM

- Agda.TypeChecking.Records: emap :: (a -> b) -> Either c (Maybe a) -> Either c (Maybe b)

- Agda.TypeChecking.Records: recordModule :: QName -> ModuleName

- Agda.TypeChecking.Reduce: blockedOrMeta :: Blocked Term -> Blocked ()

- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Reduce.InstantiateFull a) => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Reduce.Normalise a) => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Reduce.Normalise a) => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.Tele a)

- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Reduce.Reduce a) => Agda.TypeChecking.Reduce.Reduce (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Reduce.Simplify a) => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Reduce.Simplify a) => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.Tele a)

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.Syntax.Internal.PlusLevel

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate t => Agda.TypeChecking.Reduce.Instantiate (Agda.Syntax.Internal.Elim' t)

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull t => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Elim' t)

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta Agda.Syntax.Internal.Level

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta Agda.Syntax.Internal.Sort

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta Agda.Syntax.Internal.Type

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Normalise Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Normalise t => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.Elim' t)

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Reduce Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Simplify Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Simplify t => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.Elim' t)

- Agda.TypeChecking.Rewriting.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Common.Arg Agda.Syntax.Internal.DeBruijnPattern) (Agda.Syntax.Internal.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' Agda.TypeChecking.Monad.Base.NLPat)

- Agda.TypeChecking.Rewriting.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat a b => Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Internal.Elim' a) (Agda.Syntax.Internal.Elim' b)

- Agda.TypeChecking.Rewriting.Confluence: checkConfluenceOfClause :: QName -> Int -> Clause -> TCM ()

- Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.AllHoles Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.MetasToVars Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.MetasToVars a => Agda.TypeChecking.Rewriting.Confluence.MetasToVars (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match (Agda.Syntax.Internal.Type, Agda.Syntax.Internal.Term) [Agda.Syntax.Internal.Elim' Agda.TypeChecking.Monad.Base.NLPat] Agda.Syntax.Internal.Elims

- Agda.TypeChecking.Rewriting.NonLinMatch: type NLM = ExceptT Blocked_ (StateT NLMState ReduceM)

- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables a => Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm p a => Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm (Agda.Syntax.Internal.Elim' p) (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom (Agda.Syntax.Internal.Type, Agda.Syntax.Internal.Term) Agda.Syntax.Internal.Elims [Agda.Syntax.Internal.Elim' Agda.TypeChecking.Monad.Base.NLPat]

- Agda.TypeChecking.Rules.Data: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Rules.Data.CType

- Agda.TypeChecking.Rules.Data: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Rules.Data.LType

- Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term (Agda.TypeChecking.Rules.LHS.Problem.Problem a)

- Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Rules.LHS.Problem.AbsurdPattern

- Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Rules.LHS.Problem.AsBinding

- Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Rules.LHS.Problem.DotPattern

- Agda.TypeChecking.Rules.LHS.Unify: DontKnow :: [UnificationFailure] -> UnificationResult' a

- Agda.TypeChecking.Rules.Term: noFunctionsIntoSize :: Type -> Type -> TCM ()

- Agda.TypeChecking.Serialise.Base: [textC] :: Dict -> !IORef FreshAndReuse

- Agda.TypeChecking.Serialise.Base: [textD] :: Dict -> !HashTable Text Int32

- Agda.TypeChecking.Serialise.Base: [textE] :: St -> !Array Int32 Text

- Agda.TypeChecking.Serialise.Instances.Common: instance (GHC.Classes.Ord a, GHC.Classes.Ord b, Agda.TypeChecking.Serialise.Base.EmbPrj a, Agda.TypeChecking.Serialise.Base.EmbPrj b) => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.BiMap.BiMap a b)

- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.DataOrRecord

- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.HasEta

- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Utils.Empty.Empty

- Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.LibPositionInfo

- Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.LibWarning

- Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Parse.LibWarning'

- Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.PragmaOptions

- Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Concrete.Definitions.DeclarationWarning

- Agda.TypeChecking.Serialise.Instances.Highlighting: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Highlighting.Precise.CompressedFile

- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.SizedTypes.Syntax.Flexs Agda.TypeChecking.SizedTypes.Solve.SizeMeta Agda.TypeChecking.SizedTypes.Solve.HypSizeConstraint

- Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term (Agda.TypeChecking.SizedTypes.Syntax.SizeExpr' Agda.TypeChecking.SizedTypes.Solve.NamedRigid Agda.TypeChecking.SizedTypes.Solve.SizeMeta)

- Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.SizedTypes.Solve.SizeConstraint

- Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.SizedTypes.Solve.SizeMeta

- Agda.TypeChecking.SizedTypes.Syntax: instance (GHC.Classes.Ord flex, Agda.TypeChecking.SizedTypes.Syntax.Flexs flex a) => Agda.TypeChecking.SizedTypes.Syntax.Flexs flex [a]

- Agda.TypeChecking.SizedTypes.Syntax: instance (GHC.Classes.Ord r, Agda.TypeChecking.SizedTypes.Syntax.Rigids r a) => Agda.TypeChecking.SizedTypes.Syntax.Rigids r [a]

- Agda.TypeChecking.SizedTypes.Syntax: instance Agda.TypeChecking.SizedTypes.Syntax.Flexs flex (Agda.TypeChecking.SizedTypes.Syntax.SizeExpr' rigid flex)

- Agda.TypeChecking.SizedTypes.Syntax: instance Agda.TypeChecking.SizedTypes.Syntax.Rigids r (Agda.TypeChecking.SizedTypes.Syntax.SizeExpr' r f)

- Agda.TypeChecking.SizedTypes.Syntax: instance GHC.Classes.Ord flex => Agda.TypeChecking.SizedTypes.Syntax.Flexs flex (Agda.TypeChecking.SizedTypes.Syntax.Constraint' rigid flex)

- Agda.TypeChecking.SizedTypes.Syntax: instance GHC.Classes.Ord r => Agda.TypeChecking.SizedTypes.Syntax.Rigids r (Agda.TypeChecking.SizedTypes.Syntax.Constraint' r f)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.TypeChecking.Substitute.TelV a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.TypeChecking.Substitute.TelV a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Substitute.Class.Subst t b) => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Dom' a b)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Substitute.Class.Subst t b) => Agda.TypeChecking.Substitute.Class.Subst t (a, b)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Substitute.Class.Subst t b, Agda.TypeChecking.Substitute.Class.Subst t c) => Agda.TypeChecking.Substitute.Class.Subst t (a, b, c)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Substitute.Class.Subst t b, Agda.TypeChecking.Substitute.Class.Subst t c, Agda.TypeChecking.Substitute.Class.Subst t d) => Agda.TypeChecking.Substitute.Class.Subst t (a, b, c, d)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.Syntax.Internal.Tele a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst t a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.Syntax.Internal.Tele a)

- Agda.TypeChecking.Substitute: instance (GHC.Classes.Ord k, Agda.TypeChecking.Substitute.Class.Subst t a) => Agda.TypeChecking.Substitute.Class.Subst t (Data.Map.Internal.Map k a)

- Agda.TypeChecking.Substitute: instance (GHC.Types.Coercible a Agda.Syntax.Internal.Term, Agda.TypeChecking.Substitute.Class.Subst t a) => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Sort' a)

- Agda.TypeChecking.Substitute: instance (GHC.Types.Coercible a Agda.Syntax.Internal.Term, Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.Substitute.Class.Subst t b) => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Type'' a b)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.BraveTerm Agda.Syntax.Internal.BraveTerm

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.DeBruijnPattern Agda.Syntax.Internal.DeBruijnPattern

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term ()

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Abstract.Name.Name

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Abstract.ProblemEq

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Internal.ConPatternInfo

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Internal.EqualityView

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Internal.Pattern

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Internal.Term

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Position.Range

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Monad.Base.Candidate

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Monad.Base.CompareAs

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Monad.Base.Constraint

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Monad.Base.DisplayForm

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.TypeChecking.Monad.Base.DisplayTerm

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term GHC.Base.String

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term a => Agda.TypeChecking.Substitute.Class.Apply (Agda.Syntax.Internal.Tele a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPat Agda.TypeChecking.Monad.Base.NLPSort

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPat Agda.TypeChecking.Monad.Base.NLPType

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPat Agda.TypeChecking.Monad.Base.NLPat

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.NLPat Agda.TypeChecking.Monad.Base.RewriteRule

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a a => Agda.TypeChecking.Substitute.Class.Subst a (Agda.Syntax.Internal.Substitution' a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Common.Arg a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Common.Named name a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Common.WithHiding a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Blocked a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Level' a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.LevelAtom' a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.PlusLevel' a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (Agda.Syntax.Internal.Tele a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t (GHC.Maybe.Maybe a)

- Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst t a => Agda.TypeChecking.Substitute.Class.Subst t [a]

- Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.CompareAs

- Agda.TypeChecking.Substitute: instance GHC.Classes.Ord Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.Substitute: unLevelAtom :: LevelAtom -> Term

- Agda.TypeChecking.Substitute: univInf :: HasOptions m => m (Maybe Sort)

- Agda.TypeChecking.Substitute.Class: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term Agda.Syntax.Abstract.Name.QName

- Agda.TypeChecking.Substitute.DeBruijn: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.SyntacticEquality: instance (Agda.TypeChecking.Substitute.Class.Subst t a, Agda.TypeChecking.SyntacticEquality.SynEq a) => Agda.TypeChecking.SyntacticEquality.SynEq (Agda.Syntax.Internal.Abs a)

- Agda.TypeChecking.SyntacticEquality: instance Agda.TypeChecking.SyntacticEquality.SynEq Agda.Syntax.Internal.LevelAtom

- Agda.TypeChecking.SyntacticEquality: instance Agda.TypeChecking.SyntacticEquality.SynEq a => Agda.TypeChecking.SyntacticEquality.SynEq (Agda.Syntax.Internal.Elim' a)

- Agda.TypeChecking.Unquote: instance Agda.TypeChecking.Unquote.Unquote Agda.Utils.String.Str

- Agda.TypeChecking.Warnings: instance GHC.Base.Applicative m => GHC.Base.Semigroup (Control.Monad.Trans.Reader.ReaderT s m Text.PrettyPrint.HughesPJ.Doc)

- Agda.TypeChecking.Warnings: instance GHC.Base.Monad m => GHC.Base.Semigroup (Control.Monad.Trans.State.Lazy.StateT s m Text.PrettyPrint.HughesPJ.Doc)

- Agda.TypeChecking.Warnings: instance GHC.Base.Semigroup (Agda.TypeChecking.Monad.Base.TCM Text.PrettyPrint.HughesPJ.Doc)

- Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench a m => Agda.Utils.Benchmark.MonadBench a (Control.Monad.Trans.Reader.ReaderT r m)

- Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench a m => Agda.Utils.Benchmark.MonadBench a (Control.Monad.Trans.State.Lazy.StateT r m)

- Agda.Utils.BiMap: empty :: BiMap a b

- Agda.Utils.BiMap: instance (GHC.Classes.Ord a, GHC.Classes.Ord b) => GHC.Classes.Eq (Agda.Utils.BiMap.BiMap a b)

- Agda.Utils.BiMap: instance (GHC.Classes.Ord a, GHC.Classes.Ord b) => GHC.Classes.Ord (Agda.Utils.BiMap.BiMap a b)

- Agda.Utils.BiMap: instance (GHC.Show.Show a, GHC.Show.Show b) => GHC.Show.Show (Agda.Utils.BiMap.BiMap a b)

- Agda.Utils.Except: catchError :: MonadError e m => m a -> (e -> m a) -> m a

- Agda.Utils.Except: class Error a

- Agda.Utils.Except: class Monad m => MonadError e (m :: Type -> Type) | m -> e

- Agda.Utils.Except: data ExceptT e (m :: Type -> Type) a

- Agda.Utils.Except: instance Agda.Utils.Except.Error GHC.Base.String

- Agda.Utils.Except: mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b

- Agda.Utils.Except: mkExceptT :: m (Either e a) -> ExceptT e m a

- Agda.Utils.Except: noMsg :: Error a => a

- Agda.Utils.Except: runExceptT :: ExceptT e m a -> m (Either e a)

- Agda.Utils.Except: strMsg :: Error a => String -> a

- Agda.Utils.Except: throwError :: MonadError e m => e -> m a

- Agda.Utils.FileName: (===) :: AbsolutePath -> AbsolutePath -> Bool

- Agda.Utils.FileName: infix 4 ===

- Agda.Utils.FileName: rootPath :: FilePath

- Agda.Utils.Float: floatEq :: Double -> Double -> Bool

- Agda.Utils.Float: floatLt :: Double -> Double -> Bool

- Agda.Utils.Float: normaliseNaN :: Double -> Double

- Agda.Utils.Geniplate: dontDescendInto :: [TypeQ]

- Agda.Utils.Geniplate: instanceTransformBiMT' :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]

- Agda.Utils.Geniplate: instanceUniverseBiT' :: [TypeQ] -> TypeQ -> Q [Dec]

- Agda.Utils.Impossible: withFileAndLine :: (HasCallStack, Integral a) => (String -> a -> b) -> b

- Agda.Utils.Impossible: withFileAndLine' :: Integral a => CallStack -> (String -> a -> b) -> b

- Agda.Utils.Monad: readM :: (Error e, MonadError e m, Read a) => String -> m a

- Agda.Utils.Permutation: instance Agda.Syntax.Position.KillRange Agda.Utils.Permutation.Permutation

- Agda.Utils.Permutation: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Utils.Permutation.Drop a)

- Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (GHC.Base.NonEmpty a)

- Agda.Utils.String: Str :: String -> Str

- Agda.Utils.String: [unStr] :: Str -> String

- Agda.Utils.String: instance GHC.Classes.Eq Agda.Utils.String.Str

- Agda.Utils.String: instance GHC.Show.Show Agda.Utils.String.Str

- Agda.Utils.String: newtype Str

- Agda.Utils.String: showIndex :: (Show i, Integral i) => i -> String

- Agda.Utils.Suffix: NoSuffix :: Suffix

- Agda.Utils.Suffix: subscriptAllowed :: UnicodeOrAscii

- Agda.Utils.Tuple: List2 :: (a, a) -> List2 a

- Agda.Utils.Tuple: [list2] :: List2 a -> (a, a)

- Agda.Utils.Tuple: instance Data.Foldable.Foldable Agda.Utils.Tuple.List2

- Agda.Utils.Tuple: instance Data.Traversable.Traversable Agda.Utils.Tuple.List2

- Agda.Utils.Tuple: instance GHC.Base.Applicative Agda.Utils.Tuple.List2

- Agda.Utils.Tuple: instance GHC.Base.Functor Agda.Utils.Tuple.List2

- Agda.Utils.Tuple: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.Tuple.List2 a)

- Agda.Utils.Tuple: newtype List2 a

- Agda.Utils.Warshall: instance (GHC.Show.Show a, GHC.Show.Show b, GHC.Show.Show c) => GHC.Show.Show (Agda.Utils.Warshall.LegendMatrix a b c)

- Agda.Utils.Warshall: instance GHC.Show.Show Agda.Utils.Warshall.Constraint

- Agda.Utils.Warshall: instance GHC.Show.Show Agda.Utils.Warshall.Node

- Agda.Utils.Warshall: instance GHC.Show.Show Agda.Utils.Warshall.Rigid

- Agda.Utils.Warshall: instance GHC.Show.Show Agda.Utils.Warshall.SizeExpr

+ Agda.Auto.CaseSplit: instance (Agda.Auto.CaseSplit.Unify t, o GHC.Types.~ Agda.Auto.CaseSplit.UnifiesTo t) => Agda.Auto.CaseSplit.Unify (Agda.Auto.NarrowingSearch.MM t (Agda.Auto.Syntax.RefInfo o))

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace (Agda.Auto.Syntax.ArgList o) (Agda.Auto.Syntax.ArgList o)

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace (Agda.Auto.Syntax.Exp o) (Agda.Auto.Syntax.MExp o)

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace t u => Agda.Auto.CaseSplit.Replace (Agda.Auto.NarrowingSearch.MM t (Agda.Auto.Syntax.RefInfo o)) u

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Replace t u => Agda.Auto.CaseSplit.Replace (Agda.Auto.Syntax.Abs t) (Agda.Auto.Syntax.Abs u)

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify (Agda.Auto.Syntax.ArgList o)

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify (Agda.Auto.Syntax.Exp o)

+ Agda.Auto.CaseSplit: instance Agda.Auto.CaseSplit.Unify t => Agda.Auto.CaseSplit.Unify (Agda.Auto.Syntax.Abs t)

+ Agda.Auto.CaseSplit: type family UnifiesTo t;

+ Agda.Auto.CaseSplit: }

+ Agda.Auto.NarrowingSearch: instance Agda.Auto.NarrowingSearch.TravWith a blk => Agda.Auto.NarrowingSearch.Trav (Agda.Auto.NarrowingSearch.MM a blk)

+ Agda.Auto.NarrowingSearch: type TravWith a blk = (Trav a, Block a ~ blk)

+ Agda.Auto.NarrowingSearch: type family Block a;

+ Agda.Auto.NarrowingSearch: }

+ Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.ArgList o)

+ Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.Exp o)

+ Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.MId, Agda.Auto.Syntax.CExp o)

+ Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav (Agda.Auto.Syntax.TrBr a o)

+ Agda.Auto.SearchControl: instance Agda.Auto.NarrowingSearch.Trav a => Agda.Auto.NarrowingSearch.Trav [a]

+ Agda.Benchmarking: instance Agda.Utils.Benchmark.MonadBench GHC.Types.IO

+ Agda.Benchmarking: instance Control.DeepSeq.NFData Agda.Benchmarking.Phase

+ Agda.Benchmarking: instance GHC.Generics.Generic Agda.Benchmarking.Phase

+ Agda.Compiler.Backend: ACState :: [Maybe Range] -> Elims -> [Maybe (Abs Constraint)] -> Type -> a -> ArgsCheckState a

+ Agda.Compiler.Backend: AsPatternShadowsConstructorOrPatternSynonym :: Bool -> Warning

+ Agda.Compiler.Backend: BlockT :: ExceptT Blocker m a -> BlockT m a

+ Agda.Compiler.Backend: BlockedType :: Blocker -> Closure Type -> SplitError

+ Agda.Compiler.Backend: BuiltinSort :: String -> BuiltinDescriptor

+ Agda.Compiler.Backend: CheckLockedVars :: Term -> Type -> Arg Term -> Type -> Constraint

+ Agda.Compiler.Backend: CheckPatternLinearityType :: Name -> Call

+ Agda.Compiler.Backend: CheckPatternLinearityValue :: Name -> Call

+ Agda.Compiler.Backend: DisambiguatedName :: NameKind -> QName -> DisambiguatedName

+ Agda.Compiler.Backend: DontReduceDefs :: Set QName -> ReduceDefs

+ Agda.Compiler.Backend: DuplicateFieldsWarning :: [(Name, Range)] -> RecordFieldWarning

+ Agda.Compiler.Backend: DuplicateUsing :: List1 ImportedName -> Warning

+ Agda.Compiler.Backend: EmptyWhere :: Warning

+ Agda.Compiler.Backend: GenericUseless :: Range -> Doc -> Warning

+ Agda.Compiler.Backend: GlobalCandidate :: QName -> CandidateKind

+ Agda.Compiler.Backend: LocalCandidate :: CandidateKind

+ Agda.Compiler.Backend: ModuleScopeChecked :: ModuleCheckMode

+ Agda.Compiler.Backend: ModuleTypeChecked :: ModuleCheckMode

+ Agda.Compiler.Backend: NeedOptionTwoLevel :: TypeError

+ Agda.Compiler.Backend: NoGuardednessFlag :: QName -> Warning

+ Agda.Compiler.Backend: OnlyReduceDefs :: Set QName -> ReduceDefs

+ Agda.Compiler.Backend: PLockUniv :: NLPSort

+ Agda.Compiler.Backend: PrimitiveSort :: String -> Sort -> Defn

+ Agda.Compiler.Backend: PrincipalArgTypeMetas :: Args -> Type -> PrincipalArgTypeMetas

+ Agda.Compiler.Backend: ProjectedVar :: Int -> [(ProjOrigin, QName)] -> ProjectedVar

+ Agda.Compiler.Backend: RecordFieldWarning :: RecordFieldWarning -> Warning

+ Agda.Compiler.Backend: RewriteAmbiguousRules :: Term -> Term -> Term -> Warning

+ Agda.Compiler.Backend: RewriteMissingRule :: Term -> Term -> Term -> Warning

+ Agda.Compiler.Backend: SortKit :: QName -> QName -> QName -> (IsFibrant -> QName) -> SortKit

+ Agda.Compiler.Backend: SortOfSplitVarError :: Maybe Blocker -> Doc -> TypeError

+ Agda.Compiler.Backend: SplitOnNonEtaRecord :: QName -> TypeError

+ Agda.Compiler.Backend: TooManyFieldsWarning :: QName -> [Name] -> [(Name, Range)] -> RecordFieldWarning

+ Agda.Compiler.Backend: UsableAtModality :: Modality -> Term -> Constraint

+ Agda.Compiler.Backend: UselessHiding :: [ImportedName] -> Warning

+ Agda.Compiler.Backend: UselessPatternDeclarationForRecord :: String -> Warning

+ Agda.Compiler.Backend: WrongModalityForPrimitive :: String -> ArgInfo -> ArgInfo -> TypeError

+ Agda.Compiler.Backend: YesGeneralizeMeta :: DoGeneralize

+ Agda.Compiler.Backend: YesGeneralizeVar :: DoGeneralize

+ Agda.Compiler.Backend: [acConstraints] :: ArgsCheckState a -> [Maybe (Abs Constraint)]

+ Agda.Compiler.Backend: [acData] :: ArgsCheckState a -> a

+ Agda.Compiler.Backend: [acElims] :: ArgsCheckState a -> Elims

+ Agda.Compiler.Backend: [acRanges] :: ArgsCheckState a -> [Maybe Range]

+ Agda.Compiler.Backend: [acType] :: ArgsCheckState a -> Type

+ Agda.Compiler.Backend: [axiomConstTransp] :: Defn -> Bool

+ Agda.Compiler.Backend: [candidateKind] :: Candidate -> CandidateKind

+ Agda.Compiler.Backend: [cantSplitBlocker] :: SplitError -> Maybe Blocker

+ Agda.Compiler.Backend: [constraintUnblocker] :: ProblemConstraint -> Blocker

+ Agda.Compiler.Backend: [dfPatternVars] :: DisplayForm -> Nat

+ Agda.Compiler.Backend: [envConflComputingOverlap] :: TCEnv -> Bool

+ Agda.Compiler.Backend: [envReconstructed] :: TCEnv -> Bool

+ Agda.Compiler.Backend: [envReduceDefs] :: TCEnv -> ReduceDefs

+ Agda.Compiler.Backend: [envSplitOnStrict] :: TCEnv -> Bool

+ Agda.Compiler.Backend: [extLamAbsurd] :: ExtLamInfo -> Bool

+ Agda.Compiler.Backend: [iDefaultPragmaOptions] :: Interface -> [OptionsPragma]

+ Agda.Compiler.Backend: [iFilePragmaOptions] :: Interface -> [OptionsPragma]

+ Agda.Compiler.Backend: [miModality] :: MetaInfo -> Modality

+ Agda.Compiler.Backend: [miMode] :: ModuleInfo -> ModuleCheckMode

+ Agda.Compiler.Backend: [nameOfProp] :: SortKit -> QName

+ Agda.Compiler.Backend: [nameOfSSet] :: SortKit -> QName

+ Agda.Compiler.Backend: [nameOfSetOmega] :: SortKit -> IsFibrant -> QName

+ Agda.Compiler.Backend: [nameOfSet] :: SortKit -> QName

+ Agda.Compiler.Backend: [openThingCheckpointMap] :: Open a -> Map CheckpointId Substitution

+ Agda.Compiler.Backend: [openThingModule] :: Open a -> ModuleNameHash

+ Agda.Compiler.Backend: [patmMetas] :: PrincipalArgTypeMetas -> Args

+ Agda.Compiler.Backend: [patmRemainder] :: PrincipalArgTypeMetas -> Type

+ Agda.Compiler.Backend: [prProjs] :: ProjectedVar -> [(ProjOrigin, QName)]

+ Agda.Compiler.Backend: [primSort] :: Defn -> Sort

+ Agda.Compiler.Backend: [pvIndex] :: ProjectedVar -> Int

+ Agda.Compiler.Backend: [recPatternMatching] :: Defn -> PatternOrCopattern

+ Agda.Compiler.Backend: [rewFromClause] :: RewriteRule -> Bool

+ Agda.Compiler.Backend: [stPreAgdaLibFiles] :: PreScopeState -> !Map FilePath AgdaLibFile

+ Agda.Compiler.Backend: [stPreProjectConfigs] :: PreScopeState -> !Map FilePath ProjectConfig

+ Agda.Compiler.Backend: [tcErrLocation] :: TCErr -> CallStack

+ Agda.Compiler.Backend: [tcWarningLocation] :: TCWarning -> CallStack

+ Agda.Compiler.Backend: [unBlockT] :: BlockT m a -> ExceptT Blocker m a

+ Agda.Compiler.Backend: addAndUnblocker :: MonadBlock m => Blocker -> m a -> m a

+ Agda.Compiler.Backend: addOrUnblocker :: MonadBlock m => Blocker -> m a -> m a

+ Agda.Compiler.Backend: addTrustedExecutables :: CommandLineOptions -> TCM CommandLineOptions

+ Agda.Compiler.Backend: beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a

+ Agda.Compiler.Backend: builtinAgdaSortInf :: String

+ Agda.Compiler.Backend: builtinAgdaSortProp :: String

+ Agda.Compiler.Backend: builtinAgdaSortPropLit :: String

+ Agda.Compiler.Backend: builtinAgdaTCMDontReduceDefs :: String

+ Agda.Compiler.Backend: builtinAgdaTCMExec :: String

+ Agda.Compiler.Backend: builtinAgdaTCMOnlyReduceDefs :: String

+ Agda.Compiler.Backend: builtinAgdaTCMQuoteOmegaTerm :: String

+ Agda.Compiler.Backend: builtinAgdaTCMWithReconsParams :: String

+ Agda.Compiler.Backend: builtinJust :: String

+ Agda.Compiler.Backend: builtinLockUniv :: String

+ Agda.Compiler.Backend: builtinMaybe :: String

+ Agda.Compiler.Backend: builtinModality :: String

+ Agda.Compiler.Backend: builtinModalityConstructor :: String

+ Agda.Compiler.Backend: builtinNothing :: String

+ Agda.Compiler.Backend: builtinProp :: String

+ Agda.Compiler.Backend: builtinQuantity :: String

+ Agda.Compiler.Backend: builtinQuantity0 :: String

+ Agda.Compiler.Backend: builtinQuantityω :: String

+ Agda.Compiler.Backend: builtinSSetOmega :: String

+ Agda.Compiler.Backend: builtinSet :: String

+ Agda.Compiler.Backend: builtinStrictSet :: String

+ Agda.Compiler.Backend: class Monad m => MonadBlock m

+ Agda.Compiler.Backend: class (MonadTCEnv m, ReadTCState m) => MonadTrace m

+ Agda.Compiler.Backend: class (HasBuiltins m, HasConstInfo m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadTCEnv m, ReadTCState m) => PureTCM m

+ Agda.Compiler.Backend: closeVerboseBracketException :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()

+ Agda.Compiler.Backend: constTranspAxiom :: Defn

+ Agda.Compiler.Backend: crInterface :: CheckResult -> Interface

+ Agda.Compiler.Backend: crMode :: CheckResult -> ModuleCheckMode

+ Agda.Compiler.Backend: crWarnings :: CheckResult -> [TCWarning]

+ Agda.Compiler.Backend: currentModuleNameHash :: ReadTCState m => m ModuleNameHash

+ Agda.Compiler.Backend: data ArgsCheckState a

+ Agda.Compiler.Backend: data CandidateKind

+ Agda.Compiler.Backend: data CheckResult

+ Agda.Compiler.Backend: data DisambiguatedName

+ Agda.Compiler.Backend: data ModuleCheckMode

+ Agda.Compiler.Backend: data PrincipalArgTypeMetas

+ Agda.Compiler.Backend: data ProjectedVar

+ Agda.Compiler.Backend: data RecordFieldWarning

+ Agda.Compiler.Backend: data ReduceDefs

+ Agda.Compiler.Backend: data SortKit

+ Agda.Compiler.Backend: defaultAxiom :: Defn

+ Agda.Compiler.Backend: defaultGetVerbosity :: HasOptions m => m Verbosity

+ Agda.Compiler.Backend: defaultIsDebugPrinting :: MonadTCEnv m => m Bool

+ Agda.Compiler.Backend: defaultNowDebugPrinting :: MonadTCEnv m => m a -> m a

+ Agda.Compiler.Backend: eConflComputingOverlap :: Lens' Bool TCEnv

+ Agda.Compiler.Backend: eReconstructed :: Lens' Bool TCEnv

+ Agda.Compiler.Backend: eReduceDefs :: Lens' ReduceDefs TCEnv

+ Agda.Compiler.Backend: eSplitOnStrict :: Lens' Bool TCEnv

+ Agda.Compiler.Backend: getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]

+ Agda.Compiler.Backend: getLibraryOptions :: FilePath -> TCM [OptionsPragma]

+ Agda.Compiler.Backend: getPrettyVisitedModules :: ReadTCState m => m Doc

+ Agda.Compiler.Backend: getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]

+ Agda.Compiler.Backend: getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]

+ Agda.Compiler.Backend: getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]

+ Agda.Compiler.Backend: instance Control.DeepSeq.NFData Agda.Compiler.Backend.Backend

+ Agda.Compiler.Backend: instance Control.DeepSeq.NFData opts => Control.DeepSeq.NFData (Agda.Compiler.Backend.Backend' opts env menv mod def)

+ Agda.Compiler.Backend: instance GHC.Generics.Generic (Agda.Compiler.Backend.Backend' opts env menv mod def)

+ Agda.Compiler.Backend: isBuiltinNoDef :: String -> Bool

+ Agda.Compiler.Backend: isReconstructed :: MonadTCEnv m => m Bool

+ Agda.Compiler.Backend: isTwoLevelEnabled :: HasOptions m => m Bool

+ Agda.Compiler.Backend: locallyReconstructed :: MonadTCEnv m => m a -> m a

+ Agda.Compiler.Backend: locallyReduceAllDefs :: MonadTCEnv m => m a -> m a

+ Agda.Compiler.Backend: locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a

+ Agda.Compiler.Backend: locatedTypeError :: MonadTCError m => (a -> TypeError) -> HasCallStack => a -> m b

+ Agda.Compiler.Backend: newtype BlockT m a

+ Agda.Compiler.Backend: pattern CheckResult :: Interface -> [TCWarning] -> ModuleCheckMode -> Source -> CheckResult

+ Agda.Compiler.Backend: primAgdaSortInf :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaSortProp :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaSortPropLit :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaTCMDontReduceDefs :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaTCMExec :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaTCMOnlyReduceDefs :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaTCMQuoteOmegaTerm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primAgdaTCMWithReconsParams :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primJust :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primLockUniv :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primMaybe :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primModality :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primModalityConstructor :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primNothing :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primProp :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primQuantity :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primQuantity0 :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primQuantityω :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primSSetOmega :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primSet :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: primStrictSet :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.Compiler.Backend: recordFieldWarningToError :: RecordFieldWarning -> TypeError

+ Agda.Compiler.Backend: reduceAllDefs :: ReduceDefs

+ Agda.Compiler.Backend: runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)

+ Agda.Compiler.Backend: setMetaGeneralizableArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m ()

+ Agda.Compiler.Backend: shouldReduceDef :: MonadTCEnv m => QName -> m Bool

+ Agda.Compiler.Backend: showIdentitySubstitutions :: HasOptions m => m Bool

+ Agda.Compiler.Backend: sortKit :: HasBuiltins m => m SortKit

+ Agda.Compiler.Backend: stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState

+ Agda.Compiler.Backend: stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState

+ Agda.Compiler.Backend: thenReduce :: ReduceM a -> ReduceM b -> ReduceM b

+ Agda.Compiler.Backend: type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)

+ Agda.Compiler.Backend: typeError' :: MonadTCError m => CallStack -> TypeError -> m a

+ Agda.Compiler.Backend: typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr

+ Agda.Compiler.Backend: unviewProjectedVar :: ProjectedVar -> Term

+ Agda.Compiler.Backend: viewProjectedVar :: Term -> Maybe ProjectedVar

+ Agda.Compiler.Builtin: builtinBackends :: [Backend]

+ Agda.Compiler.Common: doCompile' :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> StateT (Set ModuleName) TCM r

+ Agda.Compiler.JS.Compiler: [optJSMinify] :: JSOptions -> Bool

+ Agda.Compiler.JS.Compiler: [optJSOptimize] :: JSOptions -> Bool

+ Agda.Compiler.JS.Compiler: [optJSVerify] :: JSOptions -> Bool

+ Agda.Compiler.JS.Compiler: cubicalPrimitives :: Set String

+ Agda.Compiler.JS.Compiler: eraseLocalVars :: [Bool] -> TTerm -> TTerm

+ Agda.Compiler.JS.Compiler: instance Control.DeepSeq.NFData Agda.Compiler.JS.Compiler.JSOptions

+ Agda.Compiler.JS.Compiler: instance GHC.Generics.Generic Agda.Compiler.JS.Compiler.JSOptions

+ Agda.Compiler.JS.Compiler: mergeModules :: Map ModuleName Module -> [(GlobalId, Export)]

+ Agda.Compiler.JS.Compiler: type EnvWithOpts = (JSOptions, JSModuleEnv)

+ Agda.Compiler.JS.Pretty: ($+$) :: Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: ($++$) :: Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: (<+>) :: Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: Above :: Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: Beside :: Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: Doc :: String -> Doc

+ Agda.Compiler.JS.Pretty: Empty :: Doc

+ Agda.Compiler.JS.Pretty: Enclose :: Doc -> Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: Group :: Doc -> Doc

+ Agda.Compiler.JS.Pretty: Indent :: Int -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: Space :: Doc

+ Agda.Compiler.JS.Pretty: braces :: Doc -> Doc

+ Agda.Compiler.JS.Pretty: brackets :: Doc -> Doc

+ Agda.Compiler.JS.Pretty: data Doc

+ Agda.Compiler.JS.Pretty: enclose :: Doc -> Doc -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: group :: Doc -> Doc

+ Agda.Compiler.JS.Pretty: hcat :: [Doc] -> Doc

+ Agda.Compiler.JS.Pretty: indent :: Doc -> Doc

+ Agda.Compiler.JS.Pretty: indentBy :: Int -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: infixr 5 $++$

+ Agda.Compiler.JS.Pretty: infixr 6 <+>

+ Agda.Compiler.JS.Pretty: instance Agda.Compiler.JS.Pretty.Pretty Agda.Compiler.JS.Syntax.Comment

+ Agda.Compiler.JS.Pretty: instance Agda.Compiler.JS.Pretty.Pretty [(Agda.Compiler.JS.Syntax.GlobalId, Agda.Compiler.JS.Syntax.Export)]

+ Agda.Compiler.JS.Pretty: instance Agda.Compiler.JS.Pretty.Pretty a => Agda.Compiler.JS.Pretty.Pretties (Agda.Utils.List1.List1 a)

+ Agda.Compiler.JS.Pretty: instance Agda.Compiler.JS.Pretty.Pretty a => Agda.Compiler.JS.Pretty.Pretty (GHC.Maybe.Maybe a)

+ Agda.Compiler.JS.Pretty: instance Data.String.IsString Agda.Compiler.JS.Pretty.Doc

+ Agda.Compiler.JS.Pretty: instance GHC.Base.Monoid Agda.Compiler.JS.Pretty.Doc

+ Agda.Compiler.JS.Pretty: instance GHC.Base.Semigroup Agda.Compiler.JS.Pretty.Doc

+ Agda.Compiler.JS.Pretty: minifiedCodeLinesLength :: Int

+ Agda.Compiler.JS.Pretty: mparens :: Bool -> Doc -> Doc

+ Agda.Compiler.JS.Pretty: parens :: Doc -> Doc

+ Agda.Compiler.JS.Pretty: prettyShow :: Pretty a => Bool -> a -> String

+ Agda.Compiler.JS.Pretty: punctuate :: Doc -> [Doc] -> Doc

+ Agda.Compiler.JS.Pretty: render :: Bool -> Doc -> String

+ Agda.Compiler.JS.Pretty: space :: Doc

+ Agda.Compiler.JS.Pretty: text :: String -> Doc

+ Agda.Compiler.JS.Pretty: vcat :: [Doc] -> Doc

+ Agda.Compiler.JS.Pretty: vsep :: [Doc] -> Doc

+ Agda.Compiler.JS.Syntax: Array :: [(Comment, Exp)] -> Exp

+ Agda.Compiler.JS.Syntax: Comment :: String -> Comment

+ Agda.Compiler.JS.Syntax: MemberIndex :: Int -> Comment -> MemberId

+ Agda.Compiler.JS.Syntax: Null :: Exp

+ Agda.Compiler.JS.Syntax: [callMain] :: Module -> Maybe Exp

+ Agda.Compiler.JS.Syntax: [imports] :: Module -> [GlobalId]

+ Agda.Compiler.JS.Syntax: data MemberId

+ Agda.Compiler.JS.Syntax: instance (Agda.Compiler.JS.Syntax.Globals a, Agda.Compiler.JS.Syntax.Globals b) => Agda.Compiler.JS.Syntax.Globals (a, b)

+ Agda.Compiler.JS.Syntax: instance (Agda.Compiler.JS.Syntax.Globals a, Agda.Compiler.JS.Syntax.Globals b, Agda.Compiler.JS.Syntax.Globals c) => Agda.Compiler.JS.Syntax.Globals (a, b, c)

+ Agda.Compiler.JS.Syntax: instance (Agda.Compiler.JS.Syntax.Uses a, Agda.Compiler.JS.Syntax.Uses b) => Agda.Compiler.JS.Syntax.Uses (a, b)

+ Agda.Compiler.JS.Syntax: instance (Agda.Compiler.JS.Syntax.Uses a, Agda.Compiler.JS.Syntax.Uses b, Agda.Compiler.JS.Syntax.Uses c) => Agda.Compiler.JS.Syntax.Uses (a, b, c)

+ Agda.Compiler.JS.Syntax: instance Agda.Compiler.JS.Syntax.Globals Agda.Compiler.JS.Syntax.Comment

+ Agda.Compiler.JS.Syntax: instance Agda.Compiler.JS.Syntax.Globals a => Agda.Compiler.JS.Syntax.Globals (GHC.Maybe.Maybe a)

+ 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.Eq Agda.Compiler.JS.Syntax.Exp

+ 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.JS.Syntax: type JSQName = List1 MemberId

+ Agda.Compiler.MAlonzo.Compiler: GHCCompileEnv :: GHCOptions -> GHCCompileEnv

+ Agda.Compiler.MAlonzo.Compiler: GHCDefinition :: UsesFloat -> [Decl] -> Definition -> Maybe MainFunctionDef -> Set ModuleName -> GHCDefinition

+ Agda.Compiler.MAlonzo.Compiler: GHCFlags :: Bool -> Bool -> Maybe FilePath -> [String] -> GHCFlags

+ Agda.Compiler.MAlonzo.Compiler: GHCModule :: GHCModuleEnv -> [MainFunctionDef] -> GHCModule

+ Agda.Compiler.MAlonzo.Compiler: GHCModuleEnv :: GHCCompileEnv -> HsModuleEnv -> GHCModuleEnv

+ Agda.Compiler.MAlonzo.Compiler: UsesFloat :: Bool -> UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: [flagGhcBin] :: GHCFlags -> Maybe FilePath

+ Agda.Compiler.MAlonzo.Compiler: [flagGhcCallGhc] :: GHCFlags -> Bool

+ Agda.Compiler.MAlonzo.Compiler: [flagGhcCompile] :: GHCFlags -> Bool

+ Agda.Compiler.MAlonzo.Compiler: [flagGhcFlags] :: GHCFlags -> [String]

+ Agda.Compiler.MAlonzo.Compiler: [ghcCompileEnvOpts] :: GHCCompileEnv -> GHCOptions

+ Agda.Compiler.MAlonzo.Compiler: [ghcDefDecls] :: GHCDefinition -> [Decl]

+ Agda.Compiler.MAlonzo.Compiler: [ghcDefDefinition] :: GHCDefinition -> Definition

+ Agda.Compiler.MAlonzo.Compiler: [ghcDefImports] :: GHCDefinition -> Set ModuleName

+ Agda.Compiler.MAlonzo.Compiler: [ghcDefMainDef] :: GHCDefinition -> Maybe MainFunctionDef

+ Agda.Compiler.MAlonzo.Compiler: [ghcDefUsesFloat] :: GHCDefinition -> UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: [ghcModCompileEnv] :: GHCModuleEnv -> GHCCompileEnv

+ Agda.Compiler.MAlonzo.Compiler: [ghcModEnv] :: GHCModule -> GHCModuleEnv

+ Agda.Compiler.MAlonzo.Compiler: [ghcModHsModuleEnv] :: GHCModuleEnv -> HsModuleEnv

+ Agda.Compiler.MAlonzo.Compiler: [ghcModMainFuncs] :: GHCModule -> [MainFunctionDef]

+ Agda.Compiler.MAlonzo.Compiler: [optGhcBin] :: GHCOptions -> FilePath

+ Agda.Compiler.MAlonzo.Compiler: [optGhcCompileDir] :: GHCOptions -> FilePath

+ Agda.Compiler.MAlonzo.Compiler: askGhcOpts :: ReadGHCOpts m => m GHCOptions

+ Agda.Compiler.MAlonzo.Compiler: class Monad m => ReadGHCOpts m

+ Agda.Compiler.MAlonzo.Compiler: closedTerm_ :: TTerm -> HsCompileM Exp

+ Agda.Compiler.MAlonzo.Compiler: curOutFile :: (MonadGHCIO m, ReadHsModuleEnv m) => m FilePath

+ Agda.Compiler.MAlonzo.Compiler: curOutFileAndDir :: (MonadGHCIO m, ReadHsModuleEnv m) => m (FilePath, FilePath)

+ Agda.Compiler.MAlonzo.Compiler: data GHCCompileEnv

+ Agda.Compiler.MAlonzo.Compiler: data GHCDefinition

+ Agda.Compiler.MAlonzo.Compiler: data GHCFlags

+ Agda.Compiler.MAlonzo.Compiler: data GHCModule

+ Agda.Compiler.MAlonzo.Compiler: data GHCModuleEnv

+ Agda.Compiler.MAlonzo.Compiler: defaultGHCFlags :: GHCFlags

+ Agda.Compiler.MAlonzo.Compiler: instance Control.DeepSeq.NFData Agda.Compiler.MAlonzo.Compiler.GHCFlags

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Compiler.ReadGHCOpts (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Compiler.GHCCompileEnv m)

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Compiler.ReadGHCOpts (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Compiler.GHCModule m)

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Compiler.ReadGHCOpts (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Compiler.GHCModuleEnv m)

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Compiler.ReadGHCOpts (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Compiler.GHCOptions m)

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Compiler.GHCModule m)

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Compiler.GHCModuleEnv m)

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Monoid Agda.Compiler.MAlonzo.Compiler.UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Base.Semigroup Agda.Compiler.MAlonzo.Compiler.UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Classes.Eq Agda.Compiler.MAlonzo.Compiler.UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Generics.Generic Agda.Compiler.MAlonzo.Compiler.GHCFlags

+ Agda.Compiler.MAlonzo.Compiler: instance GHC.Show.Show Agda.Compiler.MAlonzo.Compiler.UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: liftCC :: Monad m => HsCompileT m a -> CCT m a

+ Agda.Compiler.MAlonzo.Compiler: mazRTEFloatImport :: UsesFloat -> [ImportDecl]

+ Agda.Compiler.MAlonzo.Compiler: newtype UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: outFileAndDir :: MonadGHCIO m => ModuleName -> m (FilePath, FilePath)

+ Agda.Compiler.MAlonzo.Compiler: pattern NoFloat :: UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: pattern YesFloat :: UsesFloat

+ Agda.Compiler.MAlonzo.Compiler: type CCT m = ReaderT CCEnv (WriterT UsesFloat (HsCompileT m))

+ Agda.Compiler.MAlonzo.Compiler: type MonadGHCIO m = (MonadIO m, ReadGHCOpts m)

+ Agda.Compiler.MAlonzo.Compiler: withCompilerFlag :: FilePath -> Flag GHCFlags

+ Agda.Compiler.MAlonzo.Misc: HsCompileState :: Set ModuleName -> HsCompileState

+ Agda.Compiler.MAlonzo.Misc: HsModuleEnv :: ModuleName -> Bool -> HsModuleEnv

+ Agda.Compiler.MAlonzo.Misc: [mazAccumlatedImports] :: HsCompileState -> Set ModuleName

+ Agda.Compiler.MAlonzo.Misc: [mazIsMainModule] :: HsModuleEnv -> Bool

+ Agda.Compiler.MAlonzo.Misc: [mazModuleName] :: HsModuleEnv -> ModuleName

+ Agda.Compiler.MAlonzo.Misc: askHsModuleEnv :: (ReadHsModuleEnv m, MonadTrans t, Monad n, m ~ t n, ReadHsModuleEnv n) => m HsModuleEnv

+ Agda.Compiler.MAlonzo.Misc: class Monad m => ReadHsModuleEnv m

+ Agda.Compiler.MAlonzo.Misc: curAgdaMod :: ReadHsModuleEnv m => m ModuleName

+ Agda.Compiler.MAlonzo.Misc: curIsMainModule :: ReadHsModuleEnv m => m Bool

+ Agda.Compiler.MAlonzo.Misc: data HsModuleEnv

+ Agda.Compiler.MAlonzo.Misc: instance Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.Except.ExceptT e m)

+ Agda.Compiler.MAlonzo.Misc: instance Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.Compiler.MAlonzo.Misc: instance Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.Maybe.MaybeT m)

+ Agda.Compiler.MAlonzo.Misc: instance Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.State.Lazy.StateT s m)

+ Agda.Compiler.MAlonzo.Misc: instance GHC.Base.Monad m => Agda.Compiler.MAlonzo.Misc.ReadHsModuleEnv (Control.Monad.Trans.Reader.ReaderT Agda.Compiler.MAlonzo.Misc.HsModuleEnv m)

+ Agda.Compiler.MAlonzo.Misc: instance GHC.Base.Monoid Agda.Compiler.MAlonzo.Misc.HsCompileState

+ Agda.Compiler.MAlonzo.Misc: instance GHC.Base.Semigroup Agda.Compiler.MAlonzo.Misc.HsCompileState

+ Agda.Compiler.MAlonzo.Misc: instance GHC.Classes.Eq Agda.Compiler.MAlonzo.Misc.HsCompileState

+ Agda.Compiler.MAlonzo.Misc: mazHole :: Exp

+ Agda.Compiler.MAlonzo.Misc: mazRTEFloat :: ModuleName

+ Agda.Compiler.MAlonzo.Misc: newtype HsCompileState

+ Agda.Compiler.MAlonzo.Misc: rtmHole :: String -> Exp

+ Agda.Compiler.MAlonzo.Misc: runHsCompileT :: HsCompileT m a -> HsModuleEnv -> m (a, HsCompileState)

+ Agda.Compiler.MAlonzo.Misc: runHsCompileT' :: HsCompileT m a -> HsModuleEnv -> HsCompileState -> m (a, HsCompileState)

+ Agda.Compiler.MAlonzo.Misc: type HsCompileM = HsCompileT TCM

+ Agda.Compiler.MAlonzo.Misc: type HsCompileT m = ReaderT HsModuleEnv (StateT HsCompileState m)

+ Agda.Compiler.MAlonzo.Primitives: CheckedMainFunctionDef :: MainFunctionDef -> Decl -> CheckedMainFunctionDef

+ Agda.Compiler.MAlonzo.Primitives: MainFunctionDef :: Definition -> MainFunctionDef

+ Agda.Compiler.MAlonzo.Primitives: [checkedMainDecl] :: CheckedMainFunctionDef -> Decl

+ Agda.Compiler.MAlonzo.Primitives: [checkedMainDef] :: CheckedMainFunctionDef -> MainFunctionDef

+ Agda.Compiler.MAlonzo.Primitives: asMainFunctionDef :: Definition -> Maybe MainFunctionDef

+ Agda.Compiler.MAlonzo.Primitives: checkTypeOfMain' :: MainFunctionDef -> TCM CheckedMainFunctionDef

+ Agda.Compiler.MAlonzo.Primitives: data CheckedMainFunctionDef

+ Agda.Compiler.MAlonzo.Primitives: mainFunctionDefs :: Interface -> [MainFunctionDef]

+ Agda.Compiler.MAlonzo.Primitives: newtype MainFunctionDef

+ Agda.Compiler.Treeless.Subst: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Treeless.TAlt

+ Agda.Compiler.Treeless.Subst: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Treeless.TTerm

+ Agda.ImpossibleTest: impossibleTestReduceM :: HasCallStack => [String] -> TCM a

+ Agda.Interaction.Base: CheckLock :: b -> b -> OutputConstraint a b

+ Agda.Interaction.Base: CurrentFile :: AbsolutePath -> [String] -> ClockTime -> CurrentFile

+ Agda.Interaction.Base: HeadCompute :: ComputeMode

+ Agda.Interaction.Base: ShowIrrelevantArgs :: Bool -> Interaction' range

+ Agda.Interaction.Base: ToggleIrrelevantArgs :: Interaction' range

+ Agda.Interaction.Base: UsableAtMod :: Modality -> b -> OutputConstraint a b

+ Agda.Interaction.Base: [currentFileArgs] :: CurrentFile -> [String]

+ Agda.Interaction.Base: [currentFilePath] :: CurrentFile -> AbsolutePath

+ Agda.Interaction.Base: [currentFileStamp] :: CurrentFile -> ClockTime

+ Agda.Interaction.Base: data CurrentFile

+ Agda.Interaction.Base: instance GHC.Classes.Eq Agda.Interaction.Base.Rewrite

+ Agda.Interaction.Base: instance GHC.Classes.Ord Agda.Interaction.Base.Rewrite

+ Agda.Interaction.Base: instance GHC.Show.Show Agda.Interaction.Base.CurrentFile

+ Agda.Interaction.BasicOps: getGoals' :: Rewrite -> Rewrite -> TCM Goals

+ Agda.Interaction.BasicOps: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete b) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Interaction.Base.OutputConstraint a b)

+ Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.TypeChecking.Monad.Base.IPBoundary' a)

+ Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.Constraint

+ Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.ProblemConstraint

+ Agda.Interaction.BasicOps: instance Agda.Syntax.Translation.InternalToAbstract.Reify a => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.TypeChecking.Monad.Base.IPBoundary' a)

+ Agda.Interaction.BasicOps: isName :: Expr -> Maybe Name

+ Agda.Interaction.CommandLine: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Agda.TypeChecking.Monad.Base.MonadTCEnv Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Agda.TypeChecking.Monad.Base.MonadTCM Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Agda.TypeChecking.Monad.Base.MonadTCState Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Agda.TypeChecking.Monad.Base.ReadTCState Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Control.Monad.Error.Class.MonadError Agda.TypeChecking.Monad.Base.TCErr Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Control.Monad.IO.Class.MonadIO Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Control.Monad.Reader.Class.MonadReader Agda.Interaction.CommandLine.ReplEnv Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance Control.Monad.State.Class.MonadState Agda.Interaction.CommandLine.ReplState Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance GHC.Base.Applicative Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance GHC.Base.Functor Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: instance GHC.Base.Monad Agda.Interaction.CommandLine.ReplM

+ Agda.Interaction.CommandLine: runInteractionLoop :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()

+ Agda.Interaction.ExitCode: ImpossibleError :: AgdaError

+ Agda.Interaction.ExitCode: OptionError :: AgdaError

+ Agda.Interaction.ExitCode: TCMError :: AgdaError

+ Agda.Interaction.ExitCode: UnknownError :: AgdaError

+ Agda.Interaction.ExitCode: agdaErrorFromInt :: Int -> Maybe AgdaError

+ Agda.Interaction.ExitCode: agdaErrorToInt :: AgdaError -> Int

+ Agda.Interaction.ExitCode: data AgdaError

+ Agda.Interaction.ExitCode: exitAgdaWith :: AgdaError -> IO ()

+ Agda.Interaction.ExitCode: exitSuccess :: IO a

+ Agda.Interaction.ExitCode: instance GHC.Classes.Eq Agda.Interaction.ExitCode.AgdaError

+ Agda.Interaction.ExitCode: instance GHC.Enum.Bounded Agda.Interaction.ExitCode.AgdaError

+ Agda.Interaction.ExitCode: instance GHC.Enum.Enum Agda.Interaction.ExitCode.AgdaError

+ Agda.Interaction.ExitCode: instance GHC.Show.Show Agda.Interaction.ExitCode.AgdaError

+ Agda.Interaction.Highlighting.Dot: dotBackend :: Backend

+ Agda.Interaction.Highlighting.FromAbstract: instance (Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo m), Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo n)) => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo (Agda.Syntax.Common.ImportedName' m n))

+ Agda.Interaction.Highlighting.FromAbstract: instance (Agda.Interaction.Highlighting.FromAbstract.Hilite a, Agda.Interaction.Highlighting.FromAbstract.Hilite b) => Agda.Interaction.Highlighting.FromAbstract.Hilite (Data.Either.Either a b)

+ Agda.Interaction.Highlighting.FromAbstract: instance (Agda.Interaction.Highlighting.FromAbstract.Hilite a, Agda.Syntax.Abstract.Name.IsProjP a) => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Abstract.LHSCore' a)

+ Agda.Interaction.Highlighting.FromAbstract: instance (Agda.Interaction.Highlighting.FromAbstract.Hilite a, Agda.Syntax.Position.HasRange n) => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Common.Named n a)

+ Agda.Interaction.Highlighting.FromAbstract: instance (Agda.Interaction.Highlighting.FromAbstract.Hilite m, Agda.Interaction.Highlighting.FromAbstract.Hilite n, Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo m), Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo n)) => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Common.ImportDirective' m n)

+ Agda.Interaction.Highlighting.FromAbstract: instance (Agda.Syntax.Position.HasRange n, Agda.Interaction.Highlighting.FromAbstract.Hilite p, Agda.Interaction.Highlighting.FromAbstract.Hilite e) => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Common.RewriteEqn' x n p e)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo Agda.Syntax.Abstract.Name.ModuleName)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Interaction.Highlighting.FromAbstract.RenamingTo Agda.Syntax.Abstract.Name.QName)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.BindName

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.DataDefParams

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.Declaration

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.Expr

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.GeneralizeTelescope

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.LHS

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.LamBinding

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.LetBinding

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.ModuleApplication

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.Name.AmbiguousQName

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.Name.ModuleName

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.Name.QName

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.Pragma

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.ProblemEq

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.RHS

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.RecordDirectives

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.TypedBinding

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.WhereDeclarations

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Common.ArgInfo

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Common.Modality

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Common.Quantity

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Info.ModuleInfo

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Literal.Literal

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Scope.Base.ResolvedName

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.TypeChecking.Monad.Base.DisambiguatedName

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Data.Void.Void

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Abstract.Binder' a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Abstract.Clause' a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Common.Arg a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Common.WithHiding a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Syntax.Concrete.FieldAssignment' a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (Agda.Utils.List1.List1 a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite (GHC.Maybe.Maybe a)

+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite a => Agda.Interaction.Highlighting.FromAbstract.Hilite [a]

+ Agda.Interaction.Highlighting.FromAbstract: instance GHC.Base.Monoid Agda.Interaction.Highlighting.FromAbstract.Hiliter

+ Agda.Interaction.Highlighting.FromAbstract: runHighlighter :: Hilite a => SourceToModule -> AbsolutePath -> NameKinds -> a -> HighlightingInfoBuilder

+ Agda.Interaction.Highlighting.FromAbstract: type NameKinds = QName -> Maybe NameKind

+ Agda.Interaction.Highlighting.Generate: computeUnsolvedInfo :: TCM HighlightingInfoBuilder

+ Agda.Interaction.Highlighting.Generate: instance Agda.Utils.Singleton.Collection Agda.Syntax.Abstract.Views.KName Agda.Interaction.Highlighting.Generate.NameKindBuilder

+ Agda.Interaction.Highlighting.Generate: instance Agda.Utils.Singleton.Singleton Agda.Syntax.Abstract.Views.KName Agda.Interaction.Highlighting.Generate.NameKindBuilder

+ Agda.Interaction.Highlighting.Generate: instance GHC.Base.Monoid Agda.Interaction.Highlighting.Generate.NameKindBuilder

+ Agda.Interaction.Highlighting.Generate: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Generate.NameKindBuilder

+ Agda.Interaction.Highlighting.Generate: storeDisambiguatedConstructor :: Induction -> QName -> TCM ()

+ Agda.Interaction.Highlighting.Generate: storeDisambiguatedProjection :: QName -> TCM ()

+ Agda.Interaction.Highlighting.HTML: htmlBackend :: Backend

+ Agda.Interaction.Highlighting.LaTeX: latexBackend :: Backend

+ Agda.Interaction.Highlighting.Precise: DelayedMerge :: Endo [hl] -> DelayedMerge hl

+ Agda.Interaction.Highlighting.Precise: ErrorWarning :: OtherAspect

+ Agda.Interaction.Highlighting.Precise: Hole :: Aspect

+ Agda.Interaction.Highlighting.Precise: PositionMap :: IntMap Aspects -> PositionMap

+ Agda.Interaction.Highlighting.Precise: RangePair :: (Ranges, Aspects) -> RangePair

+ Agda.Interaction.Highlighting.Precise: [positionMap] :: PositionMap -> IntMap Aspects

+ Agda.Interaction.Highlighting.Precise: [rangePair] :: RangePair -> (Ranges, Aspects)

+ Agda.Interaction.Highlighting.Precise: class Convert a b

+ Agda.Interaction.Highlighting.Precise: class IsBasicRangeMap a m | m -> a

+ Agda.Interaction.Highlighting.Precise: convert :: Convert a b => a -> b

+ Agda.Interaction.Highlighting.Precise: coveringRange :: IsBasicRangeMap a m => m -> Maybe Range

+ Agda.Interaction.Highlighting.Precise: delayedMergeInvariant :: (hl -> Bool) -> DelayedMerge hl -> Bool

+ Agda.Interaction.Highlighting.Precise: highlightingInfoBuilderInvariant :: HighlightingInfoBuilder -> Bool

+ Agda.Interaction.Highlighting.Precise: highlightingInfoInvariant :: HighlightingInfo -> Bool

+ Agda.Interaction.Highlighting.Precise: insideAndOutside :: Range -> RangeMap a -> (RangeMap a, RangeMap a)

+ Agda.Interaction.Highlighting.Precise: instance Agda.Interaction.Highlighting.Precise.Convert (Agda.Interaction.Highlighting.Precise.DelayedMerge Agda.Interaction.Highlighting.Precise.PositionMap) (Agda.Utils.RangeMap.RangeMap Agda.Interaction.Highlighting.Precise.Aspects)

+ Agda.Interaction.Highlighting.Precise: instance Agda.Interaction.Highlighting.Precise.Convert (Agda.Interaction.Highlighting.Precise.DelayedMerge Agda.Interaction.Highlighting.Precise.RangePair) (Agda.Utils.RangeMap.RangeMap Agda.Interaction.Highlighting.Precise.Aspects)

+ Agda.Interaction.Highlighting.Precise: instance Agda.Interaction.Highlighting.Precise.Convert (Agda.Interaction.Highlighting.Precise.DelayedMerge Agda.Interaction.Highlighting.Precise.RangePair) Agda.Interaction.Highlighting.Precise.PositionMap

+ Agda.Interaction.Highlighting.Precise: instance Agda.Interaction.Highlighting.Precise.Convert (Agda.Utils.RangeMap.RangeMap Agda.Interaction.Highlighting.Precise.Aspects) (Agda.Utils.RangeMap.RangeMap Agda.Interaction.Highlighting.Precise.Aspects)

+ Agda.Interaction.Highlighting.Precise: instance Agda.Interaction.Highlighting.Precise.Convert Agda.Interaction.Highlighting.Precise.PositionMap (Agda.Utils.RangeMap.RangeMap Agda.Interaction.Highlighting.Precise.Aspects)

+ Agda.Interaction.Highlighting.Precise: instance Agda.Utils.RangeMap.IsBasicRangeMap Agda.Interaction.Highlighting.Precise.Aspects (Agda.Interaction.Highlighting.Precise.DelayedMerge Agda.Interaction.Highlighting.Precise.PositionMap)

+ Agda.Interaction.Highlighting.Precise: instance Agda.Utils.RangeMap.IsBasicRangeMap Agda.Interaction.Highlighting.Precise.Aspects Agda.Interaction.Highlighting.Precise.PositionMap

+ Agda.Interaction.Highlighting.Precise: instance Agda.Utils.RangeMap.IsBasicRangeMap Agda.Interaction.Highlighting.Precise.Aspects Agda.Interaction.Highlighting.Precise.RangePair

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.Aspect

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.Aspects

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.DefinitionSite

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.NameKind

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.OtherAspect

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.PositionMap

+ Agda.Interaction.Highlighting.Precise: instance Control.DeepSeq.NFData Agda.Interaction.Highlighting.Precise.RangePair

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Monoid (Agda.Interaction.Highlighting.Precise.DelayedMerge hl)

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Monoid Agda.Interaction.Highlighting.Precise.PositionMap

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Monoid hl => Agda.Interaction.Highlighting.Precise.Convert (Agda.Interaction.Highlighting.Precise.DelayedMerge hl) hl

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup (Agda.Interaction.Highlighting.Precise.DelayedMerge hl)

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Precise.Aspect

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Precise.DefinitionSite

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Precise.NameKind

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup Agda.Interaction.Highlighting.Precise.PositionMap

+ Agda.Interaction.Highlighting.Precise: instance GHC.Base.Semigroup a => Agda.Utils.RangeMap.IsBasicRangeMap a (Agda.Interaction.Highlighting.Precise.DelayedMerge (Agda.Utils.RangeMap.RangeMap a))

+ Agda.Interaction.Highlighting.Precise: instance GHC.Generics.Generic Agda.Interaction.Highlighting.Precise.Aspect

+ Agda.Interaction.Highlighting.Precise: instance GHC.Generics.Generic Agda.Interaction.Highlighting.Precise.Aspects

+ Agda.Interaction.Highlighting.Precise: instance GHC.Generics.Generic Agda.Interaction.Highlighting.Precise.DefinitionSite

+ Agda.Interaction.Highlighting.Precise: instance GHC.Generics.Generic Agda.Interaction.Highlighting.Precise.NameKind

+ Agda.Interaction.Highlighting.Precise: instance GHC.Generics.Generic Agda.Interaction.Highlighting.Precise.OtherAspect

+ Agda.Interaction.Highlighting.Precise: instance GHC.Show.Show Agda.Interaction.Highlighting.Precise.PositionMap

+ Agda.Interaction.Highlighting.Precise: instance GHC.Show.Show Agda.Interaction.Highlighting.Precise.RangePair

+ Agda.Interaction.Highlighting.Precise: instance GHC.Show.Show hl => GHC.Show.Show (Agda.Interaction.Highlighting.Precise.DelayedMerge hl)

+ Agda.Interaction.Highlighting.Precise: kindOfNameToNameKind :: KindOfName -> NameKind

+ Agda.Interaction.Highlighting.Precise: newtype DelayedMerge hl

+ Agda.Interaction.Highlighting.Precise: newtype PositionMap

+ Agda.Interaction.Highlighting.Precise: newtype RangePair

+ Agda.Interaction.Highlighting.Precise: rangePairInvariant :: RangePair -> Bool

+ Agda.Interaction.Highlighting.Precise: restrictTo :: Range -> RangeMap a -> RangeMap a

+ Agda.Interaction.Highlighting.Precise: toList :: IsBasicRangeMap a m => m -> [(Range, a)]

+ Agda.Interaction.Highlighting.Precise: type HighlightingInfoBuilder = DelayedMerge RangePair

+ 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: overlappings :: Ranges -> Ranges -> Bool

+ Agda.Interaction.Highlighting.Range: rangeToRange :: Range -> Range

+ Agda.Interaction.Imports: Source :: Text -> FileType -> SourceFile -> Module -> TopLevelModuleName -> [AgdaLibFile] -> Source

+ Agda.Interaction.Imports: [srcFileType] :: Source -> FileType

+ Agda.Interaction.Imports: [srcModuleName] :: Source -> TopLevelModuleName

+ Agda.Interaction.Imports: [srcModule] :: Source -> Module

+ Agda.Interaction.Imports: [srcOrigin] :: Source -> SourceFile

+ Agda.Interaction.Imports: [srcProjectLibs] :: Source -> [AgdaLibFile]

+ Agda.Interaction.Imports: [srcText] :: Source -> Text

+ Agda.Interaction.Imports: crInterface :: CheckResult -> Interface

+ Agda.Interaction.Imports: crMode :: CheckResult -> ModuleCheckMode

+ Agda.Interaction.Imports: crModuleInfo :: CheckResult -> ModuleInfo

+ Agda.Interaction.Imports: crSource :: CheckResult -> Source

+ Agda.Interaction.Imports: crWarnings :: CheckResult -> [TCWarning]

+ Agda.Interaction.Imports: data CheckResult

+ Agda.Interaction.Imports: data Source

+ Agda.Interaction.Imports: parseSource :: SourceFile -> TCM Source

+ Agda.Interaction.Imports: pattern CheckResult :: Interface -> [TCWarning] -> ModuleCheckMode -> Source -> CheckResult

+ Agda.Interaction.Imports: pattern TypeCheck :: () => Mode

+ Agda.Interaction.InteractionTop: atTopLevel :: CommandM a -> CommandM a

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Interaction.Base.CurrentFile

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Interaction.Response.Info_Error

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Syntax.Common.MetaId

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Syntax.Common.ProblemId

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.TypeChecking.Monad.Base.NamedMeta

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.TypeChecking.Monad.Base.TCErr

+ Agda.Interaction.JSONTop: instance Agda.Interaction.JSON.EncodeTCM Agda.TypeChecking.Monad.Base.TCWarning

+ Agda.Interaction.JSONTop: instance Data.Aeson.Types.ToJSON.ToJSON Agda.Interaction.Base.CurrentFile

+ Agda.Interaction.JSONTop: instance Data.Aeson.Types.ToJSON.ToJSON Agda.Syntax.Common.MetaId

+ Agda.Interaction.JSONTop: instance Data.Aeson.Types.ToJSON.ToJSON Agda.Syntax.Common.ProblemId

+ Agda.Interaction.Library: AgdaLibFile :: LibName -> FilePath -> [FilePath] -> [LibName] -> [String] -> AgdaLibFile

+ Agda.Interaction.Library: DefaultProjectConfig :: ProjectConfig

+ Agda.Interaction.Library: ProjectConfig :: FilePath -> [FilePath] -> ProjectConfig

+ Agda.Interaction.Library: [_libDepends] :: AgdaLibFile -> [LibName]

+ Agda.Interaction.Library: [_libFile] :: AgdaLibFile -> FilePath

+ Agda.Interaction.Library: [_libIncludes] :: AgdaLibFile -> [FilePath]

+ Agda.Interaction.Library: [_libName] :: AgdaLibFile -> LibName

+ Agda.Interaction.Library: [_libPragmas] :: AgdaLibFile -> [String]

+ Agda.Interaction.Library: [configAgdaLibFiles] :: ProjectConfig -> [FilePath]

+ Agda.Interaction.Library: [configRoot] :: ProjectConfig -> FilePath

+ Agda.Interaction.Library: data AgdaLibFile

+ Agda.Interaction.Library: data ProjectConfig

+ Agda.Interaction.Library: getAgdaLibFiles' :: FilePath -> LibErrorIO [AgdaLibFile]

+ Agda.Interaction.Library: getPrimitiveLibDir :: IO FilePath

+ Agda.Interaction.Library: getTrustedExecutables :: LibM (Map ExeName FilePath)

+ Agda.Interaction.Library: mkLibM :: [AgdaLibFile] -> LibErrorIO a -> LibM a

+ Agda.Interaction.Library: type ExeName = Text

+ Agda.Interaction.Library.Base: AmbiguousLib :: LibName -> [AgdaLibFile] -> LibError'

+ Agda.Interaction.Library.Base: DefaultProjectConfig :: ProjectConfig

+ Agda.Interaction.Library.Base: ExeNotExecutable :: ExecutablesFile -> FilePath -> LibWarning'

+ Agda.Interaction.Library.Base: ExeNotFound :: ExecutablesFile -> FilePath -> LibWarning'

+ Agda.Interaction.Library.Base: ExecutablesFile :: FilePath -> Bool -> ExecutablesFile

+ Agda.Interaction.Library.Base: LibError :: Maybe LibPositionInfo -> LibError' -> LibError

+ Agda.Interaction.Library.Base: LibNotFound :: LibrariesFile -> LibName -> LibError'

+ Agda.Interaction.Library.Base: LibPositionInfo :: Maybe FilePath -> LineNumber -> FilePath -> LibPositionInfo

+ Agda.Interaction.Library.Base: LibWarning :: Maybe LibPositionInfo -> LibWarning' -> LibWarning

+ Agda.Interaction.Library.Base: LibrariesFile :: FilePath -> Bool -> LibrariesFile

+ Agda.Interaction.Library.Base: OtherError :: String -> LibError'

+ Agda.Interaction.Library.Base: ProjectConfig :: FilePath -> [FilePath] -> ProjectConfig

+ Agda.Interaction.Library.Base: UnknownField :: String -> LibWarning'

+ Agda.Interaction.Library.Base: [_libPragmas] :: AgdaLibFile -> [String]

+ Agda.Interaction.Library.Base: [configAgdaLibFiles] :: ProjectConfig -> [FilePath]

+ Agda.Interaction.Library.Base: [configRoot] :: ProjectConfig -> FilePath

+ Agda.Interaction.Library.Base: [efExists] :: ExecutablesFile -> Bool

+ Agda.Interaction.Library.Base: [efPath] :: ExecutablesFile -> FilePath

+ Agda.Interaction.Library.Base: [filePos] :: LibPositionInfo -> FilePath

+ Agda.Interaction.Library.Base: [lfExists] :: LibrariesFile -> Bool

+ Agda.Interaction.Library.Base: [lfPath] :: LibrariesFile -> FilePath

+ Agda.Interaction.Library.Base: [libFilePos] :: LibPositionInfo -> Maybe FilePath

+ Agda.Interaction.Library.Base: [lineNumPos] :: LibPositionInfo -> LineNumber

+ Agda.Interaction.Library.Base: data ExecutablesFile

+ Agda.Interaction.Library.Base: data LibError

+ Agda.Interaction.Library.Base: data LibError'

+ Agda.Interaction.Library.Base: data LibPositionInfo

+ Agda.Interaction.Library.Base: data LibWarning

+ Agda.Interaction.Library.Base: data LibWarning'

+ Agda.Interaction.Library.Base: data LibrariesFile

+ Agda.Interaction.Library.Base: data ProjectConfig

+ Agda.Interaction.Library.Base: formatLibError :: [AgdaLibFile] -> LibError -> Doc

+ Agda.Interaction.Library.Base: formatLibPositionInfo :: LibPositionInfo -> String -> Doc

+ Agda.Interaction.Library.Base: getCachedAgdaLibFile :: (MonadState LibState m, MonadIO m) => FilePath -> m (Maybe AgdaLibFile)

+ Agda.Interaction.Library.Base: getCachedProjectConfig :: (MonadState LibState m, MonadIO m) => FilePath -> m (Maybe ProjectConfig)

+ Agda.Interaction.Library.Base: instance Agda.Utils.Pretty.Pretty Agda.Interaction.Library.Base.LibWarning

+ Agda.Interaction.Library.Base: instance Agda.Utils.Pretty.Pretty Agda.Interaction.Library.Base.LibWarning'

+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.AgdaLibFile

+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.ExecutablesFile

+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.LibPositionInfo

+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.LibWarning

+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.LibWarning'

+ Agda.Interaction.Library.Base: instance Control.DeepSeq.NFData Agda.Interaction.Library.Base.ProjectConfig

+ Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.ExecutablesFile

+ Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.LibPositionInfo

+ Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.LibWarning

+ Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.LibWarning'

+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.AgdaLibFile

+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.ExecutablesFile

+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.LibPositionInfo

+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.LibWarning

+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.LibWarning'

+ Agda.Interaction.Library.Base: instance GHC.Generics.Generic Agda.Interaction.Library.Base.ProjectConfig

+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.ExecutablesFile

+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibError'

+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibPositionInfo

+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibWarning

+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibWarning'

+ Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibrariesFile

+ Agda.Interaction.Library.Base: libPragmas :: Lens' [String] AgdaLibFile

+ Agda.Interaction.Library.Base: libraryWarningName :: LibWarning -> WarningName

+ Agda.Interaction.Library.Base: raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m ()

+ Agda.Interaction.Library.Base: raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m ()

+ Agda.Interaction.Library.Base: storeCachedAgdaLibFile :: (MonadState LibState m, MonadIO m) => FilePath -> AgdaLibFile -> m ()

+ Agda.Interaction.Library.Base: storeCachedProjectConfig :: (MonadState LibState m, MonadIO m) => FilePath -> ProjectConfig -> m ()

+ Agda.Interaction.Library.Base: type ExeName = Text

+ Agda.Interaction.Library.Base: type LibErrorIO = WriterT [Either LibError LibWarning] (StateT LibState IO)

+ Agda.Interaction.Library.Base: type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO))

+ Agda.Interaction.Library.Base: type LibState = (Map FilePath ProjectConfig, Map FilePath AgdaLibFile)

+ Agda.Interaction.Library.Base: type LineNumber = Int

+ Agda.Interaction.Library.Base: warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m ()

+ Agda.Interaction.Library.Base: warnings' :: MonadWriter [Either LibError LibWarning] m => [LibWarning'] -> m ()

+ Agda.Interaction.MakeCase: makeRHSEmptyRecord :: RHS -> RHS

+ Agda.Interaction.Monad: data IM a

+ Agda.Interaction.Monad: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance Agda.TypeChecking.Monad.Base.MonadTCEnv Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance Agda.TypeChecking.Monad.Base.MonadTCM Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance Agda.TypeChecking.Monad.Base.MonadTCState Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance Agda.TypeChecking.Monad.Base.ReadTCState Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance Control.Monad.Error.Class.MonadError Agda.TypeChecking.Monad.Base.TCErr Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance Control.Monad.IO.Class.MonadIO Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance GHC.Base.Applicative Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance GHC.Base.Functor Agda.Interaction.Monad.IM

+ Agda.Interaction.Monad: instance GHC.Base.Monad Agda.Interaction.Monad.IM

+ Agda.Interaction.Options: AsciiOnly :: UnicodeOrAscii

+ Agda.Interaction.Options: GlobalConfluenceCheck :: ConfluenceCheck

+ Agda.Interaction.Options: LocalConfluenceCheck :: ConfluenceCheck

+ Agda.Interaction.Options: UnicodeOk :: UnicodeOrAscii

+ Agda.Interaction.Options: [optAllowExec] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optCallByName] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optFirstOrder] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optGuarded] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optImportSorts] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optPrintAgdaDir] :: CommandLineOptions -> Bool

+ Agda.Interaction.Options: [optPrintHelp] :: CommandLineOptions -> Maybe Help

+ Agda.Interaction.Options: [optPrintVersion] :: CommandLineOptions -> Bool

+ Agda.Interaction.Options: [optQualifiedInstances] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optShowIdentitySubstitutions] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optTrustedExecutables] :: CommandLineOptions -> Map ExeName FilePath

+ Agda.Interaction.Options: [optTwoLevel] :: PragmaOptions -> WithDefault 'False

+ Agda.Interaction.Options: class (Functor m, Applicative m, Monad m) => HasOptions m

+ Agda.Interaction.Options: commandLineOptions :: (HasOptions m, HasOptions n, MonadTrans t, m ~ t n) => m CommandLineOptions

+ Agda.Interaction.Options: data ConfluenceCheck

+ Agda.Interaction.Options: data UnicodeOrAscii

+ Agda.Interaction.Options: pragmaOptions :: (HasOptions m, HasOptions n, MonadTrans t, m ~ t n) => m PragmaOptions

+ Agda.Interaction.Options.Help: instance Control.DeepSeq.NFData Agda.Interaction.Options.Help.Help

+ Agda.Interaction.Options.Help: instance Control.DeepSeq.NFData Agda.Interaction.Options.Help.HelpTopic

+ Agda.Interaction.Options.Help: instance GHC.Generics.Generic Agda.Interaction.Options.Help.Help

+ Agda.Interaction.Options.Help: instance GHC.Generics.Generic Agda.Interaction.Options.Help.HelpTopic

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensIncludePaths Agda.Interaction.Options.Base.CommandLineOptions

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensPersistentVerbosity Agda.Interaction.Options.Base.CommandLineOptions

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensPersistentVerbosity Agda.Interaction.Options.Base.PragmaOptions

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensPragmaOptions Agda.Interaction.Options.Base.CommandLineOptions

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensSafeMode Agda.Interaction.Options.Base.CommandLineOptions

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensSafeMode Agda.Interaction.Options.Base.PragmaOptions

+ Agda.Interaction.Options.Lenses: instance Agda.Interaction.Options.Lenses.LensVerbosity Agda.Interaction.Options.Base.PragmaOptions

+ Agda.Interaction.Options.Lenses: isPrimitiveModule :: MonadIO m => FilePath -> m Bool

+ Agda.Interaction.Options.Warnings: AsPatternShadowsConstructorOrPatternSynonym_ :: WarningName

+ Agda.Interaction.Options.Warnings: DuplicateFieldsWarning_ :: WarningName

+ Agda.Interaction.Options.Warnings: DuplicateUsing_ :: WarningName

+ Agda.Interaction.Options.Warnings: EmptyConstructor_ :: WarningName

+ Agda.Interaction.Options.Warnings: EmptyWhere_ :: WarningName

+ Agda.Interaction.Options.Warnings: ExeNotExecutableWarning_ :: WarningName

+ Agda.Interaction.Options.Warnings: ExeNotFoundWarning_ :: WarningName

+ Agda.Interaction.Options.Warnings: GenericUseless_ :: WarningName

+ Agda.Interaction.Options.Warnings: InvalidConstructorBlock_ :: WarningName

+ Agda.Interaction.Options.Warnings: InvalidConstructor_ :: WarningName

+ Agda.Interaction.Options.Warnings: InvalidRecordDirective_ :: WarningName

+ Agda.Interaction.Options.Warnings: MultipleAttributes_ :: WarningName

+ Agda.Interaction.Options.Warnings: NoGuardednessFlag_ :: WarningName

+ Agda.Interaction.Options.Warnings: NoNoError :: String -> WarningModeError

+ Agda.Interaction.Options.Warnings: RewriteAmbiguousRules_ :: WarningName

+ Agda.Interaction.Options.Warnings: RewriteMissingRule_ :: WarningName

+ Agda.Interaction.Options.Warnings: TooManyFieldsWarning_ :: WarningName

+ Agda.Interaction.Options.Warnings: Unknown :: String -> WarningModeError

+ Agda.Interaction.Options.Warnings: UnsupportedAttribute_ :: WarningName

+ Agda.Interaction.Options.Warnings: UselessHiding_ :: WarningName

+ Agda.Interaction.Options.Warnings: UselessPatternDeclarationForRecord_ :: WarningName

+ Agda.Interaction.Options.Warnings: data WarningModeError

+ Agda.Interaction.Options.Warnings: instance Control.DeepSeq.NFData Agda.Interaction.Options.Warnings.WarningMode

+ Agda.Interaction.Options.Warnings: instance Control.DeepSeq.NFData Agda.Interaction.Options.Warnings.WarningName

+ Agda.Interaction.Options.Warnings: instance GHC.Generics.Generic Agda.Interaction.Options.Warnings.WarningMode

+ Agda.Interaction.Options.Warnings: instance GHC.Generics.Generic Agda.Interaction.Options.Warnings.WarningName

+ Agda.Interaction.Options.Warnings: prettyWarningModeError :: WarningModeError -> String

+ Agda.Interaction.Response: [sShowIrrelevantArguments] :: Status -> Bool

+ Agda.Main: FrontEndEmacs :: FrontendType

+ Agda.Main: FrontEndJson :: FrontendType

+ Agda.Main: FrontEndRepl :: FrontendType

+ Agda.Main: MainModePrintAgdaDir :: MainMode

+ Agda.Main: MainModePrintHelp :: Help -> MainMode

+ Agda.Main: MainModePrintVersion :: MainMode

+ Agda.Main: MainModeRun :: Interactor () -> MainMode

+ Agda.Main: data FrontendType

+ Agda.Main: data MainMode

+ Agda.Main: defaultInteractor :: AbsolutePath -> Interactor ()

+ Agda.Main: emacsModeInteractor :: Interactor ()

+ Agda.Main: getInteractor :: MonadError String m => [Backend] -> Maybe AbsolutePath -> CommandLineOptions -> m (Maybe (Interactor ()))

+ Agda.Main: getMainMode :: MonadError String m => [Backend] -> Maybe AbsolutePath -> CommandLineOptions -> m MainMode

+ Agda.Main: jsonModeInteractor :: Interactor ()

+ Agda.Main: printAgdaDir :: IO ()

+ Agda.Main: replInteractor :: Maybe AbsolutePath -> Interactor ()

+ Agda.Main: type Interactor a = TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM a

+ Agda.Syntax.Abstract: AnnP :: PatInfo -> e -> Pattern' e -> Pattern' e

+ Agda.Syntax.Abstract: Def' :: QName -> Suffix -> Expr

+ Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.SubstExpr a => Agda.Syntax.Abstract.SubstExpr (Agda.Syntax.Concrete.FieldAssignment' a)

+ Agda.Syntax.Abstract: instance Agda.Syntax.Abstract.SubstExpr a => Agda.Syntax.Abstract.SubstExpr (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Abstract: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Abstract: instance Agda.Utils.Null.Null Agda.Syntax.Abstract.WhereDeclarations

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.BindName

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.DataDefParams

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Declaration

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Expr

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.GeneralizeTelescope

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.LHS

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.LamBinding

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.LetBinding

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.ModuleApplication

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Pragma

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.ProblemEq

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.RHS

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.ScopeCopyInfo

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.SpineLHS

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.TypedBinding

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.WhereDeclarations

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Abstract.Binder' a)

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData e => Control.DeepSeq.NFData (Agda.Syntax.Abstract.LHSCore' e)

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData e => Control.DeepSeq.NFData (Agda.Syntax.Abstract.Pattern' e)

+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData lhs => Control.DeepSeq.NFData (Agda.Syntax.Abstract.Clause' lhs)

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic (Agda.Syntax.Abstract.Binder' a)

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic (Agda.Syntax.Abstract.Clause' lhs)

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic (Agda.Syntax.Abstract.LHSCore' e)

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic (Agda.Syntax.Abstract.Pattern' e)

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.DataDefParams

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.Declaration

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.Expr

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.GeneralizeTelescope

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.LHS

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.LamBinding

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.LetBinding

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.ModuleApplication

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.Pragma

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.ProblemEq

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.RHS

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.ScopeCopyInfo

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.SpineLHS

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.TypedBinding

+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.WhereDeclarations

+ Agda.Syntax.Abstract: mkPi :: ExprInfo -> Telescope -> Expr -> Expr

+ Agda.Syntax.Abstract: mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding

+ Agda.Syntax.Abstract: pattern Def :: QName -> Expr

+ Agda.Syntax.Abstract: type NAPs1 e = List1 (NamedArg (Pattern' e))

+ Agda.Syntax.Abstract: type RecordDirectives = RecordDirectives' QName

+ Agda.Syntax.Abstract: type Telescope1 = List1 TypedBinding

+ Agda.Syntax.Abstract: type WithExpr = WithExpr' Expr

+ Agda.Syntax.Abstract: type WithExpr' e = Named BindName (Arg e)

+ Agda.Syntax.Abstract.Name: AsciiCounter :: FreshNameMode

+ Agda.Syntax.Abstract.Name: NoSuffix :: Suffix

+ Agda.Syntax.Abstract.Name: Suffix :: !Integer -> Suffix

+ Agda.Syntax.Abstract.Name: UnicodeSubscript :: FreshNameMode

+ Agda.Syntax.Abstract.Name: [nameCanonical] :: Name -> Name

+ Agda.Syntax.Abstract.Name: data FreshNameMode

+ Agda.Syntax.Abstract.Name: data Suffix

+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.AmbiguousQName

+ Agda.Syntax.Abstract.Name: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Abstract.Name: instance Data.Data.Data Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Eq Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Abstract.Name: instance GHC.Classes.Ord Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Abstract.Name: instance GHC.Show.Show Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Abstract.Name: makeName :: NameId -> Name -> Range -> Fixity' -> Bool -> Name

+ Agda.Syntax.Abstract.Name: mnameFromList1 :: List1 Name -> ModuleName

+ Agda.Syntax.Abstract.Name: mnameToList1 :: ModuleName -> List1 Name

+ Agda.Syntax.Abstract.Name: qnameToList0 :: QName -> [Name]

+ Agda.Syntax.Abstract.Pattern: instance (Agda.Syntax.Abstract.Pattern.APatternLike a, Agda.Syntax.Abstract.Pattern.APatternLike b, Agda.Syntax.Abstract.Pattern.ADotT a GHC.Types.~ Agda.Syntax.Abstract.Pattern.ADotT b) => Agda.Syntax.Abstract.Pattern.APatternLike (a, b)

+ Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike (Agda.Syntax.Abstract.Pattern' a)

+ Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a => Agda.Syntax.Abstract.Pattern.APatternLike (Agda.Syntax.Common.Arg a)

+ Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a => Agda.Syntax.Abstract.Pattern.APatternLike (Agda.Syntax.Common.Named n a)

+ Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a => Agda.Syntax.Abstract.Pattern.APatternLike (Agda.Syntax.Concrete.FieldAssignment' a)

+ Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a => Agda.Syntax.Abstract.Pattern.APatternLike (GHC.Maybe.Maybe a)

+ Agda.Syntax.Abstract.Pattern: instance Agda.Syntax.Abstract.Pattern.APatternLike a => Agda.Syntax.Abstract.Pattern.APatternLike [a]

+ Agda.Syntax.Abstract.Pattern: type family ADotT p;

+ Agda.Syntax.Abstract.Pattern: }

+ Agda.Syntax.Abstract.Views: class DeclaredNames a

+ Agda.Syntax.Abstract.Views: declaredNames :: (DeclaredNames a, Foldable t, DeclaredNames b, t b ~ a) => Collection KName m => a -> m

+ Agda.Syntax.Abstract.Views: instance (Agda.Syntax.Abstract.Views.DeclaredNames a, Agda.Syntax.Abstract.Views.DeclaredNames b) => Agda.Syntax.Abstract.Views.DeclaredNames (Data.Either.Either a b)

+ Agda.Syntax.Abstract.Views: instance (Agda.Syntax.Abstract.Views.DeclaredNames a, Agda.Syntax.Abstract.Views.DeclaredNames b) => Agda.Syntax.Abstract.Views.DeclaredNames (a, b)

+ 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.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.Clause

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.Declaration

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.Pragma

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.RHS

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.RecordDirectives

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.Views.KName

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames Agda.Syntax.Abstract.WhereDeclarations

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames a => Agda.Syntax.Abstract.Views.DeclaredNames (Agda.Syntax.Common.Arg a)

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames a => Agda.Syntax.Abstract.Views.DeclaredNames (Agda.Syntax.Common.Named name a)

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames a => Agda.Syntax.Abstract.Views.DeclaredNames (Agda.Syntax.Concrete.FieldAssignment' a)

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames a => Agda.Syntax.Abstract.Views.DeclaredNames (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames a => Agda.Syntax.Abstract.Views.DeclaredNames (GHC.Maybe.Maybe a)

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.DeclaredNames a => Agda.Syntax.Abstract.Views.DeclaredNames [a]

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.ExprLike Agda.Syntax.Abstract.BindName

+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.ExprLike a => Agda.Syntax.Abstract.Views.ExprLike (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Abstract.Views: type TraverseExprFn m a = (Applicative m, Monad m) => (Expr -> m Expr) -> a -> m a

+ Agda.Syntax.Abstract.Views: type KName = WithKind QName

+ Agda.Syntax.Abstract.Views: type TraverseExprRecFn m = forall a. ExprLike a => a -> m a

+ Agda.Syntax.Builtin: builtinAgdaSortInf :: String

+ Agda.Syntax.Builtin: builtinAgdaSortProp :: String

+ Agda.Syntax.Builtin: builtinAgdaSortPropLit :: String

+ Agda.Syntax.Builtin: builtinAgdaTCMDontReduceDefs :: String

+ Agda.Syntax.Builtin: builtinAgdaTCMExec :: String

+ Agda.Syntax.Builtin: builtinAgdaTCMOnlyReduceDefs :: String

+ Agda.Syntax.Builtin: builtinAgdaTCMQuoteOmegaTerm :: String

+ Agda.Syntax.Builtin: builtinAgdaTCMWithReconsParams :: String

+ Agda.Syntax.Builtin: builtinJust :: String

+ Agda.Syntax.Builtin: builtinLockUniv :: String

+ Agda.Syntax.Builtin: builtinMaybe :: String

+ Agda.Syntax.Builtin: builtinModality :: String

+ Agda.Syntax.Builtin: builtinModalityConstructor :: String

+ Agda.Syntax.Builtin: builtinNothing :: String

+ Agda.Syntax.Builtin: builtinProp :: String

+ Agda.Syntax.Builtin: builtinQuantity :: String

+ Agda.Syntax.Builtin: builtinQuantity0 :: String

+ Agda.Syntax.Builtin: builtinQuantityω :: String

+ Agda.Syntax.Builtin: builtinSSetOmega :: String

+ Agda.Syntax.Builtin: builtinSet :: String

+ Agda.Syntax.Builtin: builtinStrictSet :: String

+ Agda.Syntax.Builtin: isBuiltinNoDef :: String -> Bool

+ Agda.Syntax.Common: -- | The type of the name

+ Agda.Syntax.Common: Annotation :: Lock -> Annotation

+ Agda.Syntax.Common: CopatternMatching :: PatternOrCopattern

+ Agda.Syntax.Common: Erased :: Q0Origin -> Erased

+ Agda.Syntax.Common: IsLock :: Lock

+ Agda.Syntax.Common: IsNotLock :: Lock

+ Agda.Syntax.Common: ModuleNameHash :: Word64 -> ModuleNameHash

+ Agda.Syntax.Common: NotErased :: QωOrigin -> Erased

+ Agda.Syntax.Common: PatternMatching :: PatternOrCopattern

+ Agda.Syntax.Common: ProblemId :: Nat -> ProblemId

+ Agda.Syntax.Common: RecordDirectives :: Maybe (Ranged Induction) -> Maybe HasEta0 -> Maybe Range -> Maybe a -> RecordDirectives' a

+ Agda.Syntax.Common: UnderAddition :: t -> UnderAddition t

+ Agda.Syntax.Common: UnderComposition :: t -> UnderComposition t

+ Agda.Syntax.Common: [annLock] :: Annotation -> Lock

+ Agda.Syntax.Common: [argInfoAnnotation] :: ArgInfo -> Annotation

+ Agda.Syntax.Common: [recConstructor] :: RecordDirectives' a -> Maybe a

+ Agda.Syntax.Common: [recHasEta] :: RecordDirectives' a -> Maybe HasEta0

+ Agda.Syntax.Common: [recInductive] :: RecordDirectives' a -> Maybe (Ranged Induction)

+ Agda.Syntax.Common: [recPattern] :: RecordDirectives' a -> Maybe Range

+ Agda.Syntax.Common: asQuantity :: Erased -> Quantity

+ Agda.Syntax.Common: class CopatternMatchingAllowed a

+ Agda.Syntax.Common: class LensAnnotation a

+ Agda.Syntax.Common: class LensLock a

+ Agda.Syntax.Common: class PatternMatchingAllowed a

+ Agda.Syntax.Common: composeErased :: Erased -> Erased -> Erased

+ Agda.Syntax.Common: copatternMatchingAllowed :: CopatternMatchingAllowed a => a -> Bool

+ Agda.Syntax.Common: data Annotation

+ Agda.Syntax.Common: data Erased

+ Agda.Syntax.Common: data HasEta' a

+ Agda.Syntax.Common: data Lock

+ Agda.Syntax.Common: data PatternOrCopattern

+ Agda.Syntax.Common: data RecordDirectives' a

+ Agda.Syntax.Common: defaultAnnotation :: Annotation

+ Agda.Syntax.Common: defaultErased :: Erased

+ Agda.Syntax.Common: defaultLock :: Lock

+ Agda.Syntax.Common: emptyRecordDirectives :: RecordDirectives' a

+ Agda.Syntax.Common: fromImportedName :: ImportedName' a a -> a

+ Agda.Syntax.Common: getAnnotation :: (LensAnnotation a, LensArgInfo a) => a -> Annotation

+ Agda.Syntax.Common: getLock :: LensLock a => a -> Lock

+ 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: instance (Agda.Syntax.Position.KillRange qn, Agda.Syntax.Position.KillRange nm, Agda.Syntax.Position.KillRange e, Agda.Syntax.Position.KillRange p) => Agda.Syntax.Position.KillRange (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Common: instance (Agda.Utils.Pretty.Pretty nm, Agda.Utils.Pretty.Pretty p, Agda.Utils.Pretty.Pretty e) => Agda.Utils.Pretty.Pretty (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Common: instance (Control.DeepSeq.NFData qn, Control.DeepSeq.NFData nm, Control.DeepSeq.NFData p, Control.DeepSeq.NFData e) => Control.DeepSeq.NFData (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Common: instance (Data.Data.Data qn, Data.Data.Data nm, Data.Data.Data p, Data.Data.Data e) => Data.Data.Data (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Common: instance (GHC.Classes.Eq qn, GHC.Classes.Eq e, GHC.Classes.Eq nm, GHC.Classes.Eq p) => GHC.Classes.Eq (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Common: instance (GHC.Show.Show qn, GHC.Show.Show e, GHC.Show.Show nm, GHC.Show.Show p) => GHC.Show.Show (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.CopatternMatchingAllowed Agda.Syntax.Common.HasEta

+ Agda.Syntax.Common: instance Agda.Syntax.Common.CopatternMatchingAllowed Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensAnnotation (Agda.Syntax.Common.Arg t)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensAnnotation Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensAnnotation Agda.Syntax.Common.ArgInfo

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensHiding a => Agda.Syntax.Common.LensHiding (Agda.Syntax.Common.Named nm a)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensLock (Agda.Syntax.Common.Arg t)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensLock Agda.Syntax.Common.ArgInfo

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensLock Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensNamed (Agda.Syntax.Common.Named name a)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensNamed (GHC.Maybe.Maybe a)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.LensNamed a => Agda.Syntax.Common.LensNamed (Agda.Syntax.Common.Arg a)

+ Agda.Syntax.Common: instance Agda.Syntax.Common.PatternMatchingAllowed Agda.Syntax.Common.HasEta

+ Agda.Syntax.Common: instance Agda.Syntax.Common.PatternMatchingAllowed Agda.Syntax.Common.Induction

+ Agda.Syntax.Common: instance Agda.Syntax.Common.PatternMatchingAllowed Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.ArgInfo

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.Hiding

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.Modality

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.Origin

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange a => Agda.Syntax.Position.HasRange (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange a => Agda.Syntax.Position.HasRange (Agda.Syntax.Common.RecordDirectives' a)

+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.FreeVariables

+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Common.RecordDirectives' a)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.LeftClosedPOMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POMonoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance Agda.Utils.POMonoid.POSemigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance Agda.Utils.PartialOrd.PartialOrd t => Agda.Utils.PartialOrd.PartialOrd (Agda.Syntax.Common.UnderAddition t)

+ Agda.Syntax.Common: instance Agda.Utils.PartialOrd.PartialOrd t => Agda.Utils.PartialOrd.PartialOrd (Agda.Syntax.Common.UnderComposition t)

+ Agda.Syntax.Common: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.ConOrigin

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.CoverageCheck

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.Delayed

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.FileType

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.FixityLevel

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.InteractionId

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.IsAbstract

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.IsMacro

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.ModuleNameHash

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.PositivityCheck

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.ProjOrigin

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.UniverseCheck

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Common.RecordDirectives' a)

+ Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ModuleNameHash

+ Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.RecordDirectives' a)

+ Agda.Syntax.Common: instance Data.Foldable.Foldable (Agda.Syntax.Common.RewriteEqn' qn nm p)

+ Agda.Syntax.Common: instance Data.Foldable.Foldable Agda.Syntax.Common.HasEta'

+ Agda.Syntax.Common: instance Data.Traversable.Traversable (Agda.Syntax.Common.RewriteEqn' qn nm p)

+ Agda.Syntax.Common: instance Data.Traversable.Traversable Agda.Syntax.Common.HasEta'

+ Agda.Syntax.Common: instance GHC.Base.Applicative Agda.Syntax.Common.UnderAddition

+ Agda.Syntax.Common: instance GHC.Base.Applicative Agda.Syntax.Common.UnderComposition

+ Agda.Syntax.Common: instance GHC.Base.Functor (Agda.Syntax.Common.RewriteEqn' qn nm p)

+ Agda.Syntax.Common: instance GHC.Base.Functor Agda.Syntax.Common.HasEta'

+ Agda.Syntax.Common: instance GHC.Base.Functor Agda.Syntax.Common.RecordDirectives'

+ Agda.Syntax.Common: instance GHC.Base.Functor Agda.Syntax.Common.UnderAddition

+ Agda.Syntax.Common: instance GHC.Base.Functor Agda.Syntax.Common.UnderComposition

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance GHC.Base.Monoid (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderAddition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Cohesion)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Erased)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Modality)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Quantity)

+ Agda.Syntax.Common: instance GHC.Base.Semigroup (Agda.Syntax.Common.UnderComposition Agda.Syntax.Common.Relevance)

+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.ModuleNameHash

+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Syntax.Common.RecordDirectives' a)

+ Agda.Syntax.Common: instance GHC.Classes.Eq t => GHC.Classes.Eq (Agda.Syntax.Common.UnderAddition t)

+ Agda.Syntax.Common: instance GHC.Classes.Eq t => GHC.Classes.Eq (Agda.Syntax.Common.UnderComposition t)

+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.ModuleNameHash

+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance GHC.Classes.Ord t => GHC.Classes.Ord (Agda.Syntax.Common.UnderAddition t)

+ Agda.Syntax.Common: instance GHC.Classes.Ord t => GHC.Classes.Ord (Agda.Syntax.Common.UnderComposition t)

+ Agda.Syntax.Common: instance GHC.Enum.Bounded Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance GHC.Enum.Bounded Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance GHC.Enum.Enum Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance GHC.Enum.Enum Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance GHC.Enum.Enum Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.ConOrigin

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.CoverageCheck

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.Delayed

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.FileType

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.IsAbstract

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.IsMacro

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.PositivityCheck

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.ProjOrigin

+ Agda.Syntax.Common: instance GHC.Generics.Generic Agda.Syntax.Common.UniverseCheck

+ Agda.Syntax.Common: instance GHC.Num.Num Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Real.Integral Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Real.Real Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.Annotation

+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.Erased

+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.Lock

+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.ModuleNameHash

+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.PatternOrCopattern

+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.ProblemId

+ Agda.Syntax.Common: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Common.HasEta' a)

+ Agda.Syntax.Common: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Common.RecordDirectives' a)

+ Agda.Syntax.Common: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Common.UnderAddition t)

+ Agda.Syntax.Common: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Common.UnderComposition t)

+ Agda.Syntax.Common: inverseApplyModalityButNotQuantity :: LensModality a => Modality -> a -> a

+ Agda.Syntax.Common: isErased :: Erased -> Bool

+ Agda.Syntax.Common: isUnnamed :: Named name a -> Maybe a

+ Agda.Syntax.Common: mapAnnotation :: LensAnnotation a => (Annotation -> Annotation) -> a -> a

+ Agda.Syntax.Common: mapLock :: LensLock a => (Lock -> Lock) -> a -> a

+ Agda.Syntax.Common: newtype ModuleNameHash

+ Agda.Syntax.Common: newtype ProblemId

+ Agda.Syntax.Common: newtype UnderAddition t

+ Agda.Syntax.Common: newtype UnderComposition t

+ Agda.Syntax.Common: noModuleNameHash :: ModuleNameHash

+ Agda.Syntax.Common: partitionImportedNames :: [ImportedName' n m] -> ([n], [m])

+ Agda.Syntax.Common: patternMatchingAllowed :: PatternMatchingAllowed a => a -> Bool

+ Agda.Syntax.Common: sameErased :: Erased -> Erased -> Bool

+ Agda.Syntax.Common: setAnnotation :: (LensAnnotation a, LensArgInfo a) => Annotation -> a -> a

+ Agda.Syntax.Common: setLock :: LensLock a => Lock -> a -> a

+ Agda.Syntax.Common: type HasEta = HasEta' PatternOrCopattern

+ Agda.Syntax.Common: type HasEta0 = HasEta' ()

+ Agda.Syntax.Common: type HidingDirective' n m = [ImportedName' n m]

+ Agda.Syntax.Common: type RenamingDirective' n m = [Renaming' n m]

+ Agda.Syntax.Common: type family NameOf a;

+ Agda.Syntax.Common: unitCohesion :: Cohesion

+ Agda.Syntax.Common: unitModality :: Modality

+ Agda.Syntax.Common: unitQuantity :: Quantity

+ Agda.Syntax.Common: unitRelevance :: Relevance

+ Agda.Syntax.Common: }

+ Agda.Syntax.Concrete: Constructor :: Name -> IsInstance -> RecordDirective

+ Agda.Syntax.Concrete: Eta :: Ranged HasEta0 -> RecordDirective

+ Agda.Syntax.Concrete: Induction :: Ranged Induction -> RecordDirective

+ Agda.Syntax.Concrete: InterleavedMutual :: Range -> [Declaration] -> Declaration

+ Agda.Syntax.Concrete: LHSEllipsis :: Range -> LHSCore -> LHSCore

+ Agda.Syntax.Concrete: LoneConstructor :: Range -> [Declaration] -> Declaration

+ Agda.Syntax.Concrete: Mod :: [Pragma] -> [Declaration] -> Module

+ Agda.Syntax.Concrete: PatternOrCopattern :: Range -> RecordDirective

+ Agda.Syntax.Concrete: RecordDirective :: RecordDirective -> Declaration

+ Agda.Syntax.Concrete: [lhsEllipsisPat] :: LHSCore -> LHSCore

+ Agda.Syntax.Concrete: [lhsEllipsisRange] :: LHSCore -> Range

+ Agda.Syntax.Concrete: [modDecls] :: Module -> [Declaration]

+ Agda.Syntax.Concrete: [modPragmas] :: Module -> [Pragma]

+ Agda.Syntax.Concrete: data Module

+ Agda.Syntax.Concrete: data RecordDirective

+ Agda.Syntax.Concrete: dropTypeAndModality :: LamBinding -> [LamBinding]

+ Agda.Syntax.Concrete: exprToPatternWithHoles :: Expr -> Pattern

+ Agda.Syntax.Concrete: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.RecordDirective

+ Agda.Syntax.Concrete: instance Agda.Syntax.Position.KillRange Agda.Syntax.Concrete.RecordDirective

+ Agda.Syntax.Concrete: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.OpenShortHand

+ Agda.Syntax.Concrete: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.RecordDirective

+ Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.RecordDirective

+ Agda.Syntax.Concrete: instance Data.Foldable.Foldable (Agda.Syntax.Concrete.HoleContent' qn nm p)

+ Agda.Syntax.Concrete: instance Data.Traversable.Traversable (Agda.Syntax.Concrete.HoleContent' qn nm p)

+ Agda.Syntax.Concrete: instance GHC.Base.Functor (Agda.Syntax.Concrete.HoleContent' qn nm p)

+ Agda.Syntax.Concrete: instance GHC.Classes.Eq Agda.Syntax.Concrete.RecordDirective

+ Agda.Syntax.Concrete: instance GHC.Generics.Generic Agda.Syntax.Concrete.OpenShortHand

+ Agda.Syntax.Concrete: instance GHC.Show.Show Agda.Syntax.Concrete.RecordDirective

+ Agda.Syntax.Concrete: isRecordDirective :: Declaration -> Maybe RecordDirective

+ Agda.Syntax.Concrete: mkLam :: Range -> [LamBinding] -> Expr -> Expr

+ Agda.Syntax.Concrete: mkLet :: Range -> [Declaration] -> Expr -> Expr

+ Agda.Syntax.Concrete: mkTLet :: Range -> [Declaration] -> Maybe (TypedBinding' e)

+ Agda.Syntax.Concrete: observeModifiers :: Expr -> Arg Expr

+ Agda.Syntax.Concrete: observeRelevance :: Expr -> (Relevance, Expr)

+ Agda.Syntax.Concrete: rawApp :: List1 Expr -> Expr

+ Agda.Syntax.Concrete: rawAppP :: List1 Pattern -> Pattern

+ Agda.Syntax.Concrete: removeParenP :: Pattern -> Pattern

+ Agda.Syntax.Concrete: returnExpr :: Expr -> Maybe Expr

+ Agda.Syntax.Concrete: type HidingDirective = HidingDirective' Name Name

+ Agda.Syntax.Concrete: type OpAppArgs = OpAppArgs' Expr

+ Agda.Syntax.Concrete: type OpAppArgs' e = [NamedArg (MaybePlaceholder (OpApp e))]

+ Agda.Syntax.Concrete: type RecordDirectives = RecordDirectives' (Name, IsInstance)

+ Agda.Syntax.Concrete: type RenamingDirective = RenamingDirective' Name Name

+ Agda.Syntax.Concrete: type Telescope1 = List1 TypedBinding

+ Agda.Syntax.Concrete: unAppView :: AppView -> Expr

+ Agda.Syntax.Concrete.Attribute: LockAttribute :: Lock -> Attribute

+ Agda.Syntax.Concrete.Attribute: lockAttributeTable :: [(String, Lock)]

+ Agda.Syntax.Concrete.Attribute: setPristineLock :: LensLock a => Lock -> a -> Maybe a

+ Agda.Syntax.Concrete.Definitions: DeclarationException :: CallStack -> DeclarationException' -> DeclarationException

+ Agda.Syntax.Concrete.Definitions: DeclarationWarning :: CallStack -> DeclarationWarning' -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyConstructor :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions: InvalidConstructor :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions: InvalidConstructorBlock :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions: InvalidRecordDirective :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions: NiceLoneConstructor :: Range -> [NiceConstructor] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions: [deException] :: DeclarationException -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions: [deLocation] :: DeclarationException -> CallStack

+ Agda.Syntax.Concrete.Definitions: [dwLocation] :: DeclarationWarning -> CallStack

+ Agda.Syntax.Concrete.Definitions: [dwWarning] :: DeclarationWarning -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions: data DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakeAbstract Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakeAbstract Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakePrivate Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Concrete.Definitions: instance Agda.Syntax.Concrete.Definitions.MakePrivate Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Errors: AmbiguousConstructor :: Range -> Name -> [Name] -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: AmbiguousFunClauses :: LHS -> List1 Name -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: BadMacroDef :: NiceDeclaration -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: DeclarationException :: CallStack -> DeclarationException' -> DeclarationException

+ Agda.Syntax.Concrete.Definitions.Errors: DeclarationPanic :: String -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: DeclarationWarning :: CallStack -> DeclarationWarning' -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: DuplicateAnonDeclaration :: Range -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: DuplicateDefinition :: Name -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyAbstract :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyConstructor :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyField :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyGeneralize :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyInstance :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyMacro :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyMutual :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyPostulate :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyPrimitive :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: EmptyPrivate :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidCatchallPragma :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidConstructor :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidConstructorBlock :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidCoverageCheckPragma :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidMeasureMutual :: Range -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidName :: Name -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidNoPositivityCheckPragma :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidNoUniverseCheckPragma :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidRecordDirective :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: InvalidTerminationCheckPragma :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: MissingDefinitions :: [(Name, Range)] -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: MissingWithClauses :: Name -> LHS -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: MultipleEllipses :: Pattern -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: NotAllowedInMutual :: Range -> String -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: OpenPublicAbstract :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: OpenPublicPrivate :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: PolarityPragmasButNotPostulates :: [Name] -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: PragmaCompiled :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: PragmaNoTerminationCheck :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: ShadowingInTelescope :: List1 (Name, List2 Range) -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: UnknownFixityInMixfixDecl :: [Name] -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: UnknownNamesInFixityDecl :: [Name] -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: UnknownNamesInPolarityPragmas :: [Name] -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: UnquoteDefRequiresSignature :: List1 Name -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: UselessAbstract :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: UselessInstance :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: UselessPrivate :: Range -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: WrongContentBlock :: KindOfBlock -> Range -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: WrongDefinition :: Name -> DataRecOrFun -> DataRecOrFun -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: [deException] :: DeclarationException -> DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: [deLocation] :: DeclarationException -> CallStack

+ Agda.Syntax.Concrete.Definitions.Errors: [dwLocation] :: DeclarationWarning -> CallStack

+ Agda.Syntax.Concrete.Definitions.Errors: [dwWarning] :: DeclarationWarning -> DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: data DeclarationException

+ Agda.Syntax.Concrete.Definitions.Errors: data DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: data DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: data DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: declarationWarningName :: DeclarationWarning -> WarningName

+ Agda.Syntax.Concrete.Definitions.Errors: declarationWarningName' :: DeclarationWarning' -> WarningName

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.Errors.DeclarationException

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.Errors.DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.Errors.DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Errors.DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: instance GHC.Generics.Generic Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: instance GHC.Generics.Generic Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Errors.DeclarationException'

+ Agda.Syntax.Concrete.Definitions.Errors: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning

+ Agda.Syntax.Concrete.Definitions.Errors: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.Syntax.Concrete.Definitions.Errors: unsafeDeclarationWarning :: DeclarationWarning -> Bool

+ Agda.Syntax.Concrete.Definitions.Errors: unsafeDeclarationWarning' :: DeclarationWarning' -> Bool

+ Agda.Syntax.Concrete.Definitions.Monad: LoneSig :: Range -> Name -> DataRecOrFun -> LoneSig

+ Agda.Syntax.Concrete.Definitions.Monad: Nice :: ExceptT DeclarationException (State NiceEnv) a -> Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: NiceEnv :: LoneSigs -> TerminationCheck -> PositivityCheck -> UniverseCheck -> Catchall -> CoverageCheck -> NiceWarnings -> NameId -> NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: [_catchall] :: NiceEnv -> Catchall

+ Agda.Syntax.Concrete.Definitions.Monad: [_covChk] :: NiceEnv -> CoverageCheck

+ Agda.Syntax.Concrete.Definitions.Monad: [_loneSigs] :: NiceEnv -> LoneSigs

+ Agda.Syntax.Concrete.Definitions.Monad: [_nameId] :: NiceEnv -> NameId

+ Agda.Syntax.Concrete.Definitions.Monad: [_posChk] :: NiceEnv -> PositivityCheck

+ Agda.Syntax.Concrete.Definitions.Monad: [_termChk] :: NiceEnv -> TerminationCheck

+ Agda.Syntax.Concrete.Definitions.Monad: [_uniChk] :: NiceEnv -> UniverseCheck

+ Agda.Syntax.Concrete.Definitions.Monad: [loneSigKind] :: LoneSig -> DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Monad: [loneSigName] :: LoneSig -> Name

+ Agda.Syntax.Concrete.Definitions.Monad: [loneSigRange] :: LoneSig -> Range

+ Agda.Syntax.Concrete.Definitions.Monad: [niceWarn] :: NiceEnv -> NiceWarnings

+ Agda.Syntax.Concrete.Definitions.Monad: [unNice] :: Nice a -> ExceptT DeclarationException (State NiceEnv) a

+ Agda.Syntax.Concrete.Definitions.Monad: addLoneSig :: Range -> Name -> DataRecOrFun -> Nice Name

+ Agda.Syntax.Concrete.Definitions.Monad: catchallPragma :: Lens' Catchall NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: checkLoneSigs :: LoneSigs -> Nice ()

+ Agda.Syntax.Concrete.Definitions.Monad: coverageCheckPragma :: Lens' CoverageCheck NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: data LoneSig

+ Agda.Syntax.Concrete.Definitions.Monad: data NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: declarationException :: HasCallStack => DeclarationException' -> Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: declarationWarning :: HasCallStack => DeclarationWarning' -> Nice ()

+ Agda.Syntax.Concrete.Definitions.Monad: declarationWarning' :: DeclarationWarning' -> CallStack -> Nice ()

+ Agda.Syntax.Concrete.Definitions.Monad: forgetLoneSigs :: Nice ()

+ Agda.Syntax.Concrete.Definitions.Monad: getSig :: Name -> Nice (Maybe DataRecOrFun)

+ Agda.Syntax.Concrete.Definitions.Monad: getUniverseCheckFromSig :: Name -> Nice UniverseCheck

+ Agda.Syntax.Concrete.Definitions.Monad: initNiceEnv :: NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: instance Control.Monad.Error.Class.MonadError Agda.Syntax.Concrete.Definitions.Errors.DeclarationException Agda.Syntax.Concrete.Definitions.Monad.Nice

+ Agda.Syntax.Concrete.Definitions.Monad: instance Control.Monad.State.Class.MonadState Agda.Syntax.Concrete.Definitions.Monad.NiceEnv Agda.Syntax.Concrete.Definitions.Monad.Nice

+ Agda.Syntax.Concrete.Definitions.Monad: instance GHC.Base.Applicative Agda.Syntax.Concrete.Definitions.Monad.Nice

+ Agda.Syntax.Concrete.Definitions.Monad: instance GHC.Base.Functor Agda.Syntax.Concrete.Definitions.Monad.Nice

+ Agda.Syntax.Concrete.Definitions.Monad: instance GHC.Base.Monad Agda.Syntax.Concrete.Definitions.Monad.Nice

+ Agda.Syntax.Concrete.Definitions.Monad: lensNameId :: Lens' NameId NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: loneFuns :: LoneSigs -> [(Name, Name)]

+ Agda.Syntax.Concrete.Definitions.Monad: loneSigs :: Lens' LoneSigs NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: loneSigsFromLoneNames :: [(Range, Name, DataRecOrFun)] -> LoneSigs

+ Agda.Syntax.Concrete.Definitions.Monad: newtype Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: nextNameId :: Nice NameId

+ Agda.Syntax.Concrete.Definitions.Monad: niceWarning :: DeclarationWarning -> Nice ()

+ Agda.Syntax.Concrete.Definitions.Monad: noLoneSigs :: Nice Bool

+ Agda.Syntax.Concrete.Definitions.Monad: popCatchallPragma :: Nice Catchall

+ Agda.Syntax.Concrete.Definitions.Monad: positivityCheckPragma :: Lens' PositivityCheck NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: removeLoneSig :: Name -> Nice ()

+ Agda.Syntax.Concrete.Definitions.Monad: runNice :: Nice a -> (Either DeclarationException a, NiceWarnings)

+ Agda.Syntax.Concrete.Definitions.Monad: terminationCheckPragma :: Lens' TerminationCheck NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: type LoneSigs = Map Name LoneSig " We retain the 'Name' also in the codomain since 'Name' as a key is up to @Eq Name@ which ignores the range. However, without range names are not unique in case the user gives a second definition of the same name. This causes then problems in 'replaceSigs' which might replace the wrong signature. Another reason is that we want to distinguish different occurrences of 'NoName' in a mutual block (issue #4157). The 'NoName' in the codomain will have a unique 'NameId'."

+ Agda.Syntax.Concrete.Definitions.Monad: type NiceWarnings = [DeclarationWarning] " Stack of warnings. Head is last warning."

+ Agda.Syntax.Concrete.Definitions.Monad: universeCheckPragma :: Lens' UniverseCheck NiceEnv

+ Agda.Syntax.Concrete.Definitions.Monad: withCatchallPragma :: Catchall -> Nice a -> Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a

+ Agda.Syntax.Concrete.Definitions.Monad: withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a

+ Agda.Syntax.Concrete.Definitions.Types: Axiom :: Range -> Access -> IsAbstract -> IsInstance -> ArgInfo -> Name -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: Clause :: Name -> Catchall -> LHS -> RHS -> WhereClause -> [Clause] -> Clause

+ Agda.Syntax.Concrete.Definitions.Types: ConstructorBlock :: KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: DataBlock :: KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: DataName :: PositivityCheck -> UniverseCheck -> DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: FieldBlock :: KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: FunDef :: Range -> [Declaration] -> IsAbstract -> IsInstance -> TerminationCheck -> CoverageCheck -> Name -> [Clause] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: FunName :: TerminationCheck -> CoverageCheck -> DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: FunSig :: Range -> Access -> IsAbstract -> IsInstance -> IsMacro -> ArgInfo -> TerminationCheck -> CoverageCheck -> Name -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: InMutual :: InMutual

+ Agda.Syntax.Concrete.Definitions.Types: InferredMutual :: MutualChecks -> [NiceDeclaration] -> [NiceDeclaration] -> InferredMutual

+ Agda.Syntax.Concrete.Definitions.Types: InstanceBlock :: KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: InterleavedData :: (Int, NiceDeclaration) -> Maybe (Int, [[NiceConstructor]]) -> InterleavedDecl

+ Agda.Syntax.Concrete.Definitions.Types: InterleavedFun :: (Int, NiceDeclaration) -> Maybe (Int, [([Declaration], [Clause])]) -> InterleavedDecl

+ Agda.Syntax.Concrete.Definitions.Types: MutualChecks :: [TerminationCheck] -> [CoverageCheck] -> [PositivityCheck] -> MutualChecks

+ Agda.Syntax.Concrete.Definitions.Types: NiceDataDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [NiceConstructor] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceDataSig :: Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceField :: Range -> Access -> IsAbstract -> IsInstance -> TacticAttribute -> Name -> Arg Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceFunClause :: Range -> Access -> IsAbstract -> TerminationCheck -> CoverageCheck -> Catchall -> Declaration -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceGeneralize :: Range -> Access -> ArgInfo -> TacticAttribute -> Name -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceImport :: Range -> QName -> Maybe AsName -> OpenShortHand -> ImportDirective -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceLoneConstructor :: Range -> [NiceConstructor] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceModule :: Range -> Access -> IsAbstract -> QName -> Telescope -> [Declaration] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceModuleMacro :: Range -> Access -> Name -> ModuleApplication -> OpenShortHand -> ImportDirective -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceMutual :: Range -> TerminationCheck -> CoverageCheck -> PositivityCheck -> [NiceDeclaration] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceOpen :: Range -> QName -> ImportDirective -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NicePatternSyn :: Range -> Access -> Name -> [Arg Name] -> Pattern -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NicePragma :: Range -> Pragma -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> RecordDirectives -> [LamBinding] -> [Declaration] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceRecSig :: Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceUnquoteDecl :: Range -> Access -> IsAbstract -> IsInstance -> TerminationCheck -> CoverageCheck -> [Name] -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NiceUnquoteDef :: Range -> Access -> IsAbstract -> TerminationCheck -> CoverageCheck -> [Name] -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: NotInMutual :: InMutual

+ Agda.Syntax.Concrete.Definitions.Types: PostulateBlock :: KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: PrimitiveBlock :: KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: PrimitiveFunction :: Range -> Access -> IsAbstract -> Name -> Arg Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: RecName :: PositivityCheck -> UniverseCheck -> DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: [_kindPosCheck] :: DataRecOrFun -> PositivityCheck

+ Agda.Syntax.Concrete.Definitions.Types: [_kindUniCheck] :: DataRecOrFun -> UniverseCheck

+ Agda.Syntax.Concrete.Definitions.Types: [inferredBlock] :: InferredMutual -> [NiceDeclaration]

+ Agda.Syntax.Concrete.Definitions.Types: [inferredChecks] :: InferredMutual -> MutualChecks

+ Agda.Syntax.Concrete.Definitions.Types: [inferredLeftovers] :: InferredMutual -> [NiceDeclaration]

+ Agda.Syntax.Concrete.Definitions.Types: [infixDataCons] :: InterleavedDecl -> Maybe (Int, [[NiceConstructor]])

+ Agda.Syntax.Concrete.Definitions.Types: [infixDataSig] :: InterleavedDecl -> (Int, NiceDeclaration)

+ Agda.Syntax.Concrete.Definitions.Types: [infixFunClauses] :: InterleavedDecl -> Maybe (Int, [([Declaration], [Clause])])

+ Agda.Syntax.Concrete.Definitions.Types: [infixFunSig] :: InterleavedDecl -> (Int, NiceDeclaration)

+ Agda.Syntax.Concrete.Definitions.Types: [mutualCoverage] :: MutualChecks -> [CoverageCheck]

+ Agda.Syntax.Concrete.Definitions.Types: [mutualPositivity] :: MutualChecks -> [PositivityCheck]

+ Agda.Syntax.Concrete.Definitions.Types: [mutualTermination] :: MutualChecks -> [TerminationCheck]

+ Agda.Syntax.Concrete.Definitions.Types: coverageCheck :: DataRecOrFun -> CoverageCheck

+ Agda.Syntax.Concrete.Definitions.Types: data Clause

+ Agda.Syntax.Concrete.Definitions.Types: data DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: data InMutual

+ Agda.Syntax.Concrete.Definitions.Types: data InferredMutual

+ Agda.Syntax.Concrete.Definitions.Types: data InterleavedDecl

+ Agda.Syntax.Concrete.Definitions.Types: data KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: data MutualChecks

+ Agda.Syntax.Concrete.Definitions.Types: data NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: declName :: NiceDeclaration -> String

+ Agda.Syntax.Concrete.Definitions.Types: extendInferredBlock :: NiceDeclaration -> InferredMutual -> InferredMutual

+ Agda.Syntax.Concrete.Definitions.Types: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.Types.DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Concrete.Definitions.Types: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Base.Monoid Agda.Syntax.Concrete.Definitions.Types.MutualChecks

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Base.Semigroup Agda.Syntax.Concrete.Definitions.Types.MutualChecks

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Classes.Eq Agda.Syntax.Concrete.Definitions.Types.DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Classes.Eq Agda.Syntax.Concrete.Definitions.Types.InMutual

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Classes.Eq Agda.Syntax.Concrete.Definitions.Types.KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Classes.Ord Agda.Syntax.Concrete.Definitions.Types.KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Generics.Generic Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Generics.Generic Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Types.DataRecOrFun

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Types.InMutual

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Types.KindOfBlock

+ Agda.Syntax.Concrete.Definitions.Types: instance GHC.Show.Show Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: interleavedDecl :: Name -> InterleavedDecl -> [(Int, NiceDeclaration)]

+ Agda.Syntax.Concrete.Definitions.Types: isFunName :: DataRecOrFun -> Bool

+ Agda.Syntax.Concrete.Definitions.Types: isInterleavedData :: InterleavedDecl -> Maybe ()

+ Agda.Syntax.Concrete.Definitions.Types: isInterleavedFun :: InterleavedDecl -> Maybe ()

+ Agda.Syntax.Concrete.Definitions.Types: mutualChecks :: DataRecOrFun -> MutualChecks

+ Agda.Syntax.Concrete.Definitions.Types: positivityCheck :: DataRecOrFun -> PositivityCheck

+ Agda.Syntax.Concrete.Definitions.Types: sameKind :: DataRecOrFun -> DataRecOrFun -> Bool

+ Agda.Syntax.Concrete.Definitions.Types: terminationCheck :: DataRecOrFun -> TerminationCheck

+ Agda.Syntax.Concrete.Definitions.Types: type Catchall = Bool

+ Agda.Syntax.Concrete.Definitions.Types: type InterleavedMutual = Map Name InterleavedDecl

+ Agda.Syntax.Concrete.Definitions.Types: type Measure = Name

+ Agda.Syntax.Concrete.Definitions.Types: type NiceConstructor = NiceTypeSignature

+ Agda.Syntax.Concrete.Definitions.Types: type NiceTypeSignature = NiceDeclaration

+ Agda.Syntax.Concrete.Definitions.Types: type TerminationCheck = TerminationCheck Measure

+ Agda.Syntax.Concrete.Definitions.Types: universeCheck :: DataRecOrFun -> UniverseCheck

+ Agda.Syntax.Concrete.Generic: instance (Agda.Syntax.Concrete.Generic.ExprLike qn, Agda.Syntax.Concrete.Generic.ExprLike e) => Agda.Syntax.Concrete.Generic.ExprLike (Agda.Syntax.Common.RewriteEqn' qn nm p e)

+ Agda.Syntax.Concrete.Generic: instance Agda.Syntax.Concrete.Generic.ExprLike a => Agda.Syntax.Concrete.Generic.ExprLike (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Concrete.Generic: instance Agda.Syntax.Concrete.Generic.ExprLike a => Agda.Syntax.Concrete.Generic.ExprLike (Agda.Utils.List2.List2 a)

+ Agda.Syntax.Concrete.Glyph: AsciiOnly :: UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: SpecialCharacters :: (Doc -> Doc) -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> SpecialCharacters

+ Agda.Syntax.Concrete.Glyph: UnicodeOk :: UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: [_arrow] :: SpecialCharacters -> Doc

+ Agda.Syntax.Concrete.Glyph: [_dbraces] :: SpecialCharacters -> Doc -> Doc

+ Agda.Syntax.Concrete.Glyph: [_emptyIdiomBrkt] :: SpecialCharacters -> Doc

+ Agda.Syntax.Concrete.Glyph: [_forallQ] :: SpecialCharacters -> Doc

+ Agda.Syntax.Concrete.Glyph: [_lambda] :: SpecialCharacters -> Doc

+ Agda.Syntax.Concrete.Glyph: [_leftIdiomBrkt] :: SpecialCharacters -> Doc

+ Agda.Syntax.Concrete.Glyph: [_rightIdiomBrkt] :: SpecialCharacters -> Doc

+ Agda.Syntax.Concrete.Glyph: arrow :: Doc

+ Agda.Syntax.Concrete.Glyph: braces' :: Doc -> Doc

+ Agda.Syntax.Concrete.Glyph: data SpecialCharacters

+ Agda.Syntax.Concrete.Glyph: data UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: dbraces :: Doc -> Doc

+ Agda.Syntax.Concrete.Glyph: emptyIdiomBrkt :: Doc

+ Agda.Syntax.Concrete.Glyph: forallQ :: Doc

+ Agda.Syntax.Concrete.Glyph: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: instance GHC.Classes.Eq Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: instance GHC.Enum.Bounded Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: instance GHC.Enum.Enum Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: instance GHC.Generics.Generic Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: instance GHC.Show.Show Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.Syntax.Concrete.Glyph: lambda :: Doc

+ Agda.Syntax.Concrete.Glyph: leftIdiomBrkt :: Doc

+ Agda.Syntax.Concrete.Glyph: rightIdiomBrkt :: Doc

+ Agda.Syntax.Concrete.Glyph: specialCharactersForGlyphs :: UnicodeOrAscii -> SpecialCharacters

+ Agda.Syntax.Concrete.Glyph: unsafeSetUnicodeOrAscii :: UnicodeOrAscii -> IO ()

+ Agda.Syntax.Concrete.Name: AsciiCounter :: FreshNameMode

+ Agda.Syntax.Concrete.Name: UnicodeSubscript :: FreshNameMode

+ Agda.Syntax.Concrete.Name: data FreshNameMode

+ Agda.Syntax.Concrete.Name: instance Agda.Syntax.Concrete.Name.NumHoles Agda.Syntax.Concrete.Name.NameParts

+ Agda.Syntax.Concrete.Name: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Name.TopLevelModuleName

+ Agda.Syntax.Concrete.Name: instance GHC.Generics.Generic Agda.Syntax.Concrete.Name.TopLevelModuleName

+ Agda.Syntax.Concrete.Name: lastIdPart :: Lens' RawName NameParts

+ Agda.Syntax.Concrete.Name: lensNameParts :: Lens' NameParts Name

+ Agda.Syntax.Concrete.Name: lensQNameName :: Lens' Name QName

+ Agda.Syntax.Concrete.Name: nameSuffix :: Lens' (Maybe Suffix) Name

+ Agda.Syntax.Concrete.Name: nameSuffixView :: Name -> (Maybe Suffix, Name)

+ Agda.Syntax.Concrete.Name: nextRawName :: FreshNameMode -> RawName -> RawName

+ Agda.Syntax.Concrete.Name: setNameSuffix :: Maybe Suffix -> Name -> Name

+ Agda.Syntax.Concrete.Name: simpleBinaryOperator :: RawName -> Name

+ Agda.Syntax.Concrete.Name: simpleHole :: Name

+ Agda.Syntax.Concrete.Name: simpleName :: RawName -> Name

+ Agda.Syntax.Concrete.Name: type NameParts = List1 NamePart

+ Agda.Syntax.Concrete.Operators: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Operators.ParseLHS

+ Agda.Syntax.Concrete.Pattern: instance Agda.Syntax.Concrete.Pattern.CPatternLike p => Agda.Syntax.Concrete.Pattern.CPatternLike (Agda.Utils.List1.List1 p)

+ Agda.Syntax.Concrete.Pattern: instance Agda.Syntax.Concrete.Pattern.CPatternLike p => Agda.Syntax.Concrete.Pattern.CPatternLike (Agda.Utils.List2.List2 p)

+ Agda.Syntax.Concrete.Pretty: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Common.Associativity

+ Agda.Syntax.Concrete.Pretty: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Common.FixityLevel

+ Agda.Syntax.Concrete.Pretty: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Common.Modality

+ Agda.Syntax.Concrete.Pretty: instance GHC.Show.Show Agda.Syntax.Concrete.Module

+ Agda.Syntax.Concrete.Pretty: pHasEta0 :: HasEta0 -> Doc

+ Agda.Syntax.Concrete.Pretty: pRecordDirective :: RecordDirective -> Doc

+ Agda.Syntax.Concrete.Pretty: prettyErased :: Erased -> Doc -> Doc

+ Agda.Syntax.Fixity: instance Control.DeepSeq.NFData Agda.Syntax.Fixity.ParenPreference

+ Agda.Syntax.Fixity: instance Control.DeepSeq.NFData Agda.Syntax.Fixity.Precedence

+ Agda.Syntax.Fixity: instance GHC.Generics.Generic Agda.Syntax.Fixity.ParenPreference

+ Agda.Syntax.Fixity: instance GHC.Generics.Generic Agda.Syntax.Fixity.Precedence

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.AppInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.ConPatInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.ConPatLazy

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.DeclInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.ExprInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.LHSInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.LetInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.MetaInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.ModuleInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.MutualInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData Agda.Syntax.Info.PatInfo

+ Agda.Syntax.Info: instance Control.DeepSeq.NFData t => Control.DeepSeq.NFData (Agda.Syntax.Info.DefInfo' t)

+ Agda.Syntax.Info: instance GHC.Base.Monoid Agda.Syntax.Info.PatInfo

+ Agda.Syntax.Info: instance GHC.Base.Semigroup Agda.Syntax.Info.PatInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic (Agda.Syntax.Info.DefInfo' t)

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.AppInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.ConPatInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.ConPatLazy

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.DeclInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.LHSInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.MetaInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.ModuleInfo

+ Agda.Syntax.Info: instance GHC.Generics.Generic Agda.Syntax.Info.MutualInfo

+ Agda.Syntax.Internal: IdiomType :: Type -> EqualityView

+ Agda.Syntax.Internal: IsData :: DataOrRecord

+ Agda.Syntax.Internal: IsFibrant :: IsFibrant

+ Agda.Syntax.Internal: IsRecord :: PatternOrCopattern -> DataOrRecord

+ Agda.Syntax.Internal: IsStrict :: IsFibrant

+ Agda.Syntax.Internal: LockUniv :: Sort' t

+ Agda.Syntax.Internal: ProblemId :: Nat -> ProblemId

+ Agda.Syntax.Internal: SSet :: Level' t -> Sort' t

+ Agda.Syntax.Internal: [clauseExact] :: Clause -> Maybe Bool

+ Agda.Syntax.Internal: [conDataRecord] :: ConHead -> DataOrRecord

+ Agda.Syntax.Internal: data DataOrRecord

+ Agda.Syntax.Internal: data IsFibrant

+ Agda.Syntax.Internal: dummyLocName :: CallStack -> String

+ Agda.Syntax.Internal: dummyTermWith :: DummyTermKind -> CallStack -> Term

+ Agda.Syntax.Internal: instance Agda.Syntax.Common.LensAnnotation (Agda.Syntax.Internal.Dom' t e)

+ Agda.Syntax.Internal: instance Agda.Syntax.Common.LensNamed (Agda.Syntax.Internal.Dom' t e)

+ Agda.Syntax.Internal: instance Agda.Syntax.Internal.LensSort Agda.Syntax.Internal.Sort

+ Agda.Syntax.Internal: instance Agda.Syntax.Internal.PatternVars (Agda.Syntax.Common.Arg (Agda.Syntax.Internal.Pattern' a))

+ Agda.Syntax.Internal: instance Agda.Syntax.Internal.PatternVars (Agda.Syntax.Common.NamedArg (Agda.Syntax.Internal.Pattern' a))

+ Agda.Syntax.Internal: instance Agda.Syntax.Internal.PatternVars a => Agda.Syntax.Internal.PatternVars [a]

+ Agda.Syntax.Internal: instance Agda.Syntax.Position.KillRange Agda.Syntax.Internal.DataOrRecord

+ Agda.Syntax.Internal: instance Agda.Utils.Pretty.Pretty t => Agda.Utils.Pretty.Pretty (Agda.Syntax.Internal.Abs t)

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.Clause

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.ConHead

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.ConPatternInfo

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.DBPatVar

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.DataOrRecord

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.IsFibrant

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.PatOrigin

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData Agda.Syntax.Internal.PatternInfo

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.Abs a)

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.Substitution' a)

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.Tele a)

+ Agda.Syntax.Internal: instance Control.DeepSeq.NFData x => Control.DeepSeq.NFData (Agda.Syntax.Internal.Pattern' x)

+ Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.DataOrRecord

+ Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.IsFibrant

+ Agda.Syntax.Internal: instance Data.Foldable.Foldable Agda.Syntax.Internal.Level'

+ Agda.Syntax.Internal: instance Data.Foldable.Foldable Agda.Syntax.Internal.PlusLevel'

+ Agda.Syntax.Internal: instance Data.Traversable.Traversable Agda.Syntax.Internal.Level'

+ Agda.Syntax.Internal: instance Data.Traversable.Traversable Agda.Syntax.Internal.PlusLevel'

+ Agda.Syntax.Internal: instance GHC.Base.Functor Agda.Syntax.Internal.Level'

+ Agda.Syntax.Internal: instance GHC.Base.Functor Agda.Syntax.Internal.PlusLevel'

+ Agda.Syntax.Internal: instance GHC.Classes.Eq Agda.Syntax.Internal.DataOrRecord

+ Agda.Syntax.Internal: instance GHC.Classes.Eq Agda.Syntax.Internal.IsFibrant

+ Agda.Syntax.Internal: instance GHC.Classes.Ord Agda.Syntax.Internal.IsFibrant

+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.Abs a)

+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.Pattern' x)

+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.Substitution' a)

+ Agda.Syntax.Internal: instance GHC.Generics.Generic (Agda.Syntax.Internal.Tele a)

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.Clause

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.ConHead

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.ConPatternInfo

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.DBPatVar

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.DataOrRecord

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.IsFibrant

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.PatOrigin

+ Agda.Syntax.Internal: instance GHC.Generics.Generic Agda.Syntax.Internal.PatternInfo

+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.DataOrRecord

+ Agda.Syntax.Internal: instance GHC.Show.Show Agda.Syntax.Internal.IsFibrant

+ Agda.Syntax.Internal: mkSSet :: Integer -> Sort

+ Agda.Syntax.Internal: newtype ProblemId

+ Agda.Syntax.Internal: tmSSort :: Term -> Sort

+ Agda.Syntax.Internal: type Blocked = Blocked' Term

+ Agda.Syntax.Internal: type DummyTermKind = String

+ Agda.Syntax.Internal: type NotBlocked = NotBlocked' Term

+ Agda.Syntax.Internal: type family PatternVarOut a;

+ Agda.Syntax.Internal: }

+ Agda.Syntax.Internal.Blockers: AbsurdMatch :: NotBlocked' t

+ Agda.Syntax.Internal.Blockers: Blocked :: Blocker -> a -> Blocked' t a

+ Agda.Syntax.Internal.Blockers: DontWakeUp :: Maybe Blocker -> WakeUp

+ Agda.Syntax.Internal.Blockers: MissingClauses :: NotBlocked' t

+ Agda.Syntax.Internal.Blockers: NotBlocked :: NotBlocked' t -> a -> Blocked' t a

+ Agda.Syntax.Internal.Blockers: ReallyNotBlocked :: NotBlocked' t

+ Agda.Syntax.Internal.Blockers: StuckOn :: Elim' t -> NotBlocked' t

+ Agda.Syntax.Internal.Blockers: UnblockOnAll :: Set Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: UnblockOnAny :: Set Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: UnblockOnMeta :: MetaId -> Blocker

+ Agda.Syntax.Internal.Blockers: UnblockOnProblem :: ProblemId -> Blocker

+ Agda.Syntax.Internal.Blockers: Underapplied :: NotBlocked' t

+ Agda.Syntax.Internal.Blockers: WakeUp :: WakeUp

+ Agda.Syntax.Internal.Blockers: [blockingStatus] :: Blocked' t a -> NotBlocked' t

+ Agda.Syntax.Internal.Blockers: [ignoreBlocking] :: Blocked' t a -> a

+ Agda.Syntax.Internal.Blockers: [theBlocker] :: Blocked' t a -> Blocker

+ Agda.Syntax.Internal.Blockers: allBlockingMetas :: Blocker -> Set MetaId

+ Agda.Syntax.Internal.Blockers: allBlockingProblems :: Blocker -> Set ProblemId

+ Agda.Syntax.Internal.Blockers: alwaysUnblock :: Blocker

+ Agda.Syntax.Internal.Blockers: blocked :: MetaId -> a -> Blocked' t a

+ Agda.Syntax.Internal.Blockers: blockedOn :: Blocker -> a -> Blocked' t a

+ Agda.Syntax.Internal.Blockers: blocked_ :: MetaId -> Blocked' t ()

+ Agda.Syntax.Internal.Blockers: data Blocked' t a

+ Agda.Syntax.Internal.Blockers: data Blocker

+ Agda.Syntax.Internal.Blockers: data NotBlocked' t

+ Agda.Syntax.Internal.Blockers: data WakeUp

+ Agda.Syntax.Internal.Blockers: instance (Control.DeepSeq.NFData t, Control.DeepSeq.NFData a) => Control.DeepSeq.NFData (Agda.Syntax.Internal.Blockers.Blocked' t a)

+ Agda.Syntax.Internal.Blockers: instance (Data.Data.Data t, Data.Data.Data a) => Data.Data.Data (Agda.Syntax.Internal.Blockers.Blocked' t a)

+ Agda.Syntax.Internal.Blockers: instance (GHC.Base.Semigroup a, GHC.Base.Monoid a) => GHC.Base.Monoid (Agda.Syntax.Internal.Blockers.Blocked' t a)

+ Agda.Syntax.Internal.Blockers: instance (GHC.Show.Show a, GHC.Show.Show t) => GHC.Show.Show (Agda.Syntax.Internal.Blockers.Blocked' t a)

+ Agda.Syntax.Internal.Blockers: instance Agda.Utils.Functor.Decoration (Agda.Syntax.Internal.Blockers.Blocked' t)

+ Agda.Syntax.Internal.Blockers: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance Control.DeepSeq.NFData Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance Control.DeepSeq.NFData t => Control.DeepSeq.NFData (Agda.Syntax.Internal.Blockers.NotBlocked' t)

+ Agda.Syntax.Internal.Blockers: instance Data.Data.Data Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.Blockers.NotBlocked' t)

+ Agda.Syntax.Internal.Blockers: instance Data.Foldable.Foldable (Agda.Syntax.Internal.Blockers.Blocked' t)

+ Agda.Syntax.Internal.Blockers: instance Data.Traversable.Traversable (Agda.Syntax.Internal.Blockers.Blocked' t)

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Applicative (Agda.Syntax.Internal.Blockers.Blocked' t)

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Functor (Agda.Syntax.Internal.Blockers.Blocked' t)

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Monoid (Agda.Syntax.Internal.Blockers.NotBlocked' t)

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Monoid Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Semigroup (Agda.Syntax.Internal.Blockers.NotBlocked' t)

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Semigroup Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.Syntax.Internal.Blockers.Blocked' t a)

+ Agda.Syntax.Internal.Blockers: instance GHC.Classes.Eq Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance GHC.Classes.Eq Agda.Syntax.Internal.Blockers.WakeUp

+ Agda.Syntax.Internal.Blockers: instance GHC.Classes.Ord Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance GHC.Generics.Generic (Agda.Syntax.Internal.Blockers.Blocked' t a)

+ Agda.Syntax.Internal.Blockers: instance GHC.Generics.Generic (Agda.Syntax.Internal.Blockers.NotBlocked' t)

+ Agda.Syntax.Internal.Blockers: instance GHC.Generics.Generic Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance GHC.Show.Show Agda.Syntax.Internal.Blockers.Blocker

+ Agda.Syntax.Internal.Blockers: instance GHC.Show.Show Agda.Syntax.Internal.Blockers.WakeUp

+ Agda.Syntax.Internal.Blockers: instance GHC.Show.Show t => GHC.Show.Show (Agda.Syntax.Internal.Blockers.NotBlocked' t)

+ Agda.Syntax.Internal.Blockers: neverUnblock :: Blocker

+ Agda.Syntax.Internal.Blockers: notBlocked :: a -> Blocked' t a

+ Agda.Syntax.Internal.Blockers: notBlocked_ :: Blocked' t ()

+ Agda.Syntax.Internal.Blockers: onBlockingMetasM :: Monad m => (MetaId -> m Blocker) -> Blocker -> m Blocker

+ Agda.Syntax.Internal.Blockers: stuckOn :: Elim' t -> NotBlocked' t -> NotBlocked' t

+ Agda.Syntax.Internal.Blockers: unblockMeta :: MetaId -> Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnAll :: Set Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnAllMetas :: Set MetaId -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnAny :: Set Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnAnyMeta :: Set MetaId -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnEither :: Blocker -> Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnMeta :: MetaId -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockOnProblem :: ProblemId -> Blocker

+ Agda.Syntax.Internal.Blockers: unblockProblem :: ProblemId -> Blocker -> Blocker

+ Agda.Syntax.Internal.Blockers: wakeIfBlockedOnMeta :: MetaId -> Blocker -> WakeUp

+ Agda.Syntax.Internal.Blockers: wakeIfBlockedOnProblem :: ProblemId -> Blocker -> WakeUp

+ Agda.Syntax.Internal.Blockers: wakeUpWhen :: (constr -> Bool) -> (constr -> WakeUp) -> constr -> WakeUp

+ Agda.Syntax.Internal.Blockers: wakeUpWhen_ :: (constr -> Bool) -> constr -> WakeUp

+ Agda.Syntax.Internal.Defs: instance Agda.Syntax.Internal.Defs.GetDefs a => Agda.Syntax.Internal.Defs.GetDefs (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: Apply :: Arg a -> Elim' a

+ Agda.Syntax.Internal.Elim: IApply :: a -> a -> a -> Elim' a

+ Agda.Syntax.Internal.Elim: Proj :: ProjOrigin -> QName -> Elim' a

+ Agda.Syntax.Internal.Elim: allApplyElims :: [Elim' a] -> Maybe [Arg a]

+ Agda.Syntax.Internal.Elim: allProjElims :: [Elim' t] -> Maybe [(ProjOrigin, QName)]

+ Agda.Syntax.Internal.Elim: argsFromElims :: [Elim' t] -> [Arg t]

+ Agda.Syntax.Internal.Elim: class IsProjElim e

+ Agda.Syntax.Internal.Elim: data Elim' a

+ Agda.Syntax.Internal.Elim: instance Agda.Syntax.Common.LensOrigin (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: instance Agda.Syntax.Internal.Elim.IsProjElim (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: instance Agda.Utils.Pretty.Pretty tm => Agda.Utils.Pretty.Pretty (Agda.Syntax.Internal.Elim.Elim' tm)

+ Agda.Syntax.Internal.Elim: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: instance Data.Foldable.Foldable Agda.Syntax.Internal.Elim.Elim'

+ Agda.Syntax.Internal.Elim: instance Data.Traversable.Traversable Agda.Syntax.Internal.Elim.Elim'

+ Agda.Syntax.Internal.Elim: instance GHC.Base.Functor Agda.Syntax.Internal.Elim.Elim'

+ Agda.Syntax.Internal.Elim: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Elim: isApplyElim :: Elim' a -> Maybe (Arg a)

+ Agda.Syntax.Internal.Elim: isApplyElim' :: Empty -> Elim' a -> Arg a

+ Agda.Syntax.Internal.Elim: isProjElim :: IsProjElim e => e -> Maybe (ProjOrigin, QName)

+ Agda.Syntax.Internal.Elim: splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])

+ Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.Generic.TermLike (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.MetaVars: allMetas' :: (TermLike a, Monoid m) => (MetaId -> m) -> a -> m

+ Agda.Syntax.Internal.MetaVars: class AllMetas t

+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.MetaVars.AllMetas a, Agda.Syntax.Internal.MetaVars.AllMetas b) => Agda.Syntax.Internal.MetaVars.AllMetas (a, b)

+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.MetaVars.AllMetas a, Agda.Syntax.Internal.MetaVars.AllMetas b, Agda.Syntax.Internal.MetaVars.AllMetas c) => Agda.Syntax.Internal.MetaVars.AllMetas (a, b, c)

+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.MetaVars.AllMetas a, Agda.Syntax.Internal.MetaVars.AllMetas b, Agda.Syntax.Internal.MetaVars.AllMetas c, Agda.Syntax.Internal.MetaVars.AllMetas d) => Agda.Syntax.Internal.MetaVars.AllMetas (a, b, c, d)

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.Dom a)

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.Tele a)

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.Level

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.PlusLevel

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.Sort

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.Term

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.Syntax.Internal.Type

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas a => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Common.Arg a)

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas a => Agda.Syntax.Internal.MetaVars.AllMetas (GHC.Maybe.Maybe a)

+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas a => Agda.Syntax.Internal.MetaVars.AllMetas [a]

+ Agda.Syntax.Internal.MetaVars: unblockOnAllMetasIn :: AllMetas t => t -> Blocker

+ Agda.Syntax.Internal.MetaVars: unblockOnAnyMetaIn :: AllMetas t => t -> Blocker

+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Data.Map.Internal.Map k a)

+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Data.Set.Internal.Set a)

+ Agda.Syntax.Internal.Names: namesIn' :: (NamesIn a, Monoid m, Foldable f, NamesIn b, f b ~ a) => (QName -> m) -> a -> m

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars Agda.Syntax.Internal.Pattern Agda.Syntax.Internal.DeBruijnPattern

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars a b => Agda.Syntax.Internal.Pattern.LabelPatVars (Agda.Syntax.Common.Arg a) (Agda.Syntax.Common.Arg b)

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars a b => Agda.Syntax.Internal.Pattern.LabelPatVars (Agda.Syntax.Common.Named x a) (Agda.Syntax.Common.Named x b)

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.LabelPatVars a b => Agda.Syntax.Internal.Pattern.LabelPatVars [a] [b]

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities (Agda.Syntax.Internal.Pattern' x)

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities a => Agda.Syntax.Internal.Pattern.PatternVarModalities (Agda.Syntax.Common.Arg a)

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities a => Agda.Syntax.Internal.Pattern.PatternVarModalities (Agda.Syntax.Common.Named s a)

+ Agda.Syntax.Internal.Pattern: instance Agda.Syntax.Internal.Pattern.PatternVarModalities a => Agda.Syntax.Internal.Pattern.PatternVarModalities [a]

+ Agda.Syntax.Internal.Pattern: type family PatVar p;

+ Agda.Syntax.Internal.Pattern: }

+ Agda.Syntax.Literal: showText :: Text -> ShowS

+ Agda.Syntax.Literal: type RLiteral = Ranged Literal

+ Agda.Syntax.Notation: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Notation.NewNotation

+ Agda.Syntax.Notation: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Notation.NotationKind

+ Agda.Syntax.Notation: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Notation.NotationSection

+ Agda.Syntax.Notation: instance Control.DeepSeq.NFData Agda.Syntax.Notation.NewNotation

+ Agda.Syntax.Notation: instance Control.DeepSeq.NFData Agda.Syntax.Notation.NotationKind

+ Agda.Syntax.Notation: instance Control.DeepSeq.NFData Agda.Syntax.Notation.NotationSection

+ Agda.Syntax.Notation: instance GHC.Generics.Generic Agda.Syntax.Notation.NewNotation

+ Agda.Syntax.Notation: instance GHC.Generics.Generic Agda.Syntax.Notation.NotationKind

+ Agda.Syntax.Notation: instance GHC.Generics.Generic Agda.Syntax.Notation.NotationSection

+ Agda.Syntax.Parser: MultipleAttributes :: Range -> !Maybe String -> ParseWarning

+ Agda.Syntax.Parser: UnsupportedAttribute :: Range -> !Maybe String -> ParseWarning

+ Agda.Syntax.Parser: instance Control.Monad.State.Class.MonadState [Agda.Syntax.Parser.Monad.ParseWarning] Agda.Syntax.Parser.PM

+ Agda.Syntax.Parser.Alex: LexAction :: (PreviousInput -> CurrentInput -> TokenLength -> Parser r) -> LexAction r

+ Agda.Syntax.Parser.Alex: [runLexAction] :: LexAction r -> PreviousInput -> CurrentInput -> TokenLength -> Parser r

+ Agda.Syntax.Parser.Alex: instance Control.Monad.State.Class.MonadState Agda.Syntax.Parser.Monad.ParseState Agda.Syntax.Parser.Alex.LexAction

+ Agda.Syntax.Parser.Alex: instance GHC.Base.Applicative Agda.Syntax.Parser.Alex.LexAction

+ Agda.Syntax.Parser.Alex: instance GHC.Base.Functor Agda.Syntax.Parser.Alex.LexAction

+ Agda.Syntax.Parser.Alex: instance GHC.Base.Monad Agda.Syntax.Parser.Alex.LexAction

+ Agda.Syntax.Parser.Alex: newtype LexAction r

+ Agda.Syntax.Parser.Layout: confirmLayout :: Parser ()

+ Agda.Syntax.Parser.Layout: newLayoutBlock :: LexAction Token

+ Agda.Syntax.Parser.LexActions: andThen :: Parser () -> LexAction r -> LexAction r

+ Agda.Syntax.Parser.LexActions: infixr 1 `andThen`

+ Agda.Syntax.Parser.LexActions: skip :: LexAction Token

+ Agda.Syntax.Parser.Monad: Confirmed :: LayoutStatus

+ Agda.Syntax.Parser.Monad: MultipleAttributes :: Range -> !Maybe String -> ParseWarning

+ Agda.Syntax.Parser.Monad: Tentative :: LayoutStatus

+ Agda.Syntax.Parser.Monad: UnsupportedAttribute :: Range -> !Maybe String -> ParseWarning

+ Agda.Syntax.Parser.Monad: [parseLayKw] :: ParseState -> Keyword

+ Agda.Syntax.Parser.Monad: [parseLayStatus] :: ParseState -> LayoutStatus

+ Agda.Syntax.Parser.Monad: [parseWarnings] :: ParseState -> ![ParseWarning]

+ Agda.Syntax.Parser.Monad: data LayoutBlock

+ Agda.Syntax.Parser.Monad: data LayoutStatus

+ Agda.Syntax.Parser.Monad: getContext :: MonadState ParseState m => m LayoutContext

+ Agda.Syntax.Parser.Monad: instance Control.DeepSeq.NFData Agda.Syntax.Parser.Monad.ParseWarning

+ Agda.Syntax.Parser.Monad: instance GHC.Classes.Eq Agda.Syntax.Parser.Monad.LayoutStatus

+ Agda.Syntax.Parser.Monad: instance GHC.Show.Show Agda.Syntax.Parser.Monad.LayoutBlock

+ Agda.Syntax.Parser.Monad: instance GHC.Show.Show Agda.Syntax.Parser.Monad.LayoutStatus

+ Agda.Syntax.Parser.Monad: modifyContext :: (LayoutContext -> LayoutContext) -> Parser ()

+ Agda.Syntax.Parser.Monad: parseWarning :: ParseWarning -> Parser ()

+ Agda.Syntax.Parser.Monad: popBlock :: Parser ()

+ Agda.Syntax.Parser.Monad: pushBlock :: LayoutBlock -> Parser ()

+ Agda.Syntax.Parser.Monad: resetLayoutStatus :: Parser ()

+ Agda.Syntax.Parser.Monad: setContext :: LayoutContext -> Parser ()

+ Agda.Syntax.Parser.Monad: topBlock :: Parser (Maybe LayoutBlock)

+ Agda.Syntax.Parser.Monad: type Column = Int32

+ Agda.Syntax.Parser.Monad: type LayoutContext = [LayoutBlock]

+ Agda.Syntax.Parser.Parser: instance GHC.Base.Functor Agda.Syntax.Parser.Parser.LamBinds'

+ Agda.Syntax.Parser.Tokens: KwInterleaved :: Keyword

+ Agda.Syntax.Position: instance Agda.Syntax.Position.HasRange a => Agda.Syntax.Position.HasRange (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Position: instance Agda.Syntax.Position.HasRange a => Agda.Syntax.Position.HasRange (Agda.Utils.List2.List2 a)

+ Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange Agda.Utils.Permutation.Permutation

+ Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Utils.List2.List2 a)

+ Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange a => Agda.Syntax.Position.KillRange (Agda.Utils.Permutation.Drop a)

+ Agda.Syntax.Position: instance Control.DeepSeq.NFData Agda.Syntax.Position.Interval

+ Agda.Syntax.Position: instance Control.DeepSeq.NFData Agda.Syntax.Position.IntervalWithoutFile

+ Agda.Syntax.Position: instance Control.DeepSeq.NFData Agda.Syntax.Position.Position

+ Agda.Syntax.Position: instance Control.DeepSeq.NFData Agda.Syntax.Position.PositionWithoutFile

+ Agda.Syntax.Position: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Syntax.Position.Range' a)

+ Agda.Syntax.Position: instance GHC.Base.Semigroup Agda.Utils.FileName.AbsolutePath

+ Agda.Syntax.Position: instance GHC.Base.Semigroup a => GHC.Base.Monoid (Agda.Syntax.Position.Range' a)

+ Agda.Syntax.Position: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.Syntax.Position.Range' a)

+ Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Interval' a)

+ Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Position' a)

+ Agda.Syntax.Position: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Position.Range' a)

+ Agda.Syntax.Reflected: InfS :: Integer -> Sort

+ Agda.Syntax.Reflected: PropLitS :: Integer -> Sort

+ Agda.Syntax.Reflected: PropS :: Term -> Sort

+ Agda.Syntax.Reflected: [clausePats] :: Clause -> [Arg Pattern]

+ Agda.Syntax.Reflected: [clauseRHS] :: Clause -> Term

+ Agda.Syntax.Reflected: [clauseTel] :: Clause -> [(Text, Arg Type)]

+ Agda.Syntax.Scope.Base: CoConName :: KindOfName

+ Agda.Syntax.Scope.Base: IsDataModule :: DataOrRecordModule

+ Agda.Syntax.Scope.Base: IsRecordModule :: DataOrRecordModule

+ Agda.Syntax.Scope.Base: NameMapEntry :: KindOfName -> List1 QName -> NameMapEntry

+ Agda.Syntax.Scope.Base: WithBound :: BindingSource

+ Agda.Syntax.Scope.Base: WithKind :: KindOfName -> a -> WithKind a

+ Agda.Syntax.Scope.Base: [kindedThing] :: WithKind a -> a

+ Agda.Syntax.Scope.Base: [qnameConcrete] :: NameMapEntry -> List1 QName

+ Agda.Syntax.Scope.Base: [qnameKind] :: NameMapEntry -> KindOfName

+ Agda.Syntax.Scope.Base: [theKind] :: WithKind a -> KindOfName

+ Agda.Syntax.Scope.Base: approxConInduction :: Foldable t => t Induction -> Induction

+ Agda.Syntax.Scope.Base: conKindOfName :: Induction -> KindOfName

+ Agda.Syntax.Scope.Base: conKindOfName' :: Foldable t => t Induction -> KindOfName

+ Agda.Syntax.Scope.Base: data DataOrRecordModule

+ Agda.Syntax.Scope.Base: data NameMapEntry

+ Agda.Syntax.Scope.Base: data WithKind a

+ Agda.Syntax.Scope.Base: exactConInduction :: Foldable t => t Induction -> Maybe Induction

+ Agda.Syntax.Scope.Base: exactConName :: Foldable t => t Induction -> Maybe KindOfName

+ Agda.Syntax.Scope.Base: instance Agda.Utils.Null.Null Agda.Syntax.Scope.Base.Scope

+ Agda.Syntax.Scope.Base: instance Agda.Utils.Null.Null Agda.Syntax.Scope.Base.ScopeInfo

+ Agda.Syntax.Scope.Base: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Abstract.Name.Suffix

+ Agda.Syntax.Scope.Base: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Scope.Base.BindingSource

+ 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.BindingSource

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.DataOrRecordModule

+ 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.LocalVar

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.NameMapEntry

+ 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.NameOrModule

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.NameSpace

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.NameSpaceId

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.ResolvedName

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.Scope

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.ScopeInfo

+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.WhyInScope

+ Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.DataOrRecordModule

+ Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.NameMapEntry

+ Agda.Syntax.Scope.Base: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Scope.Base.WithKind a)

+ Agda.Syntax.Scope.Base: instance Data.Foldable.Foldable Agda.Syntax.Scope.Base.WithKind

+ Agda.Syntax.Scope.Base: instance Data.Traversable.Traversable Agda.Syntax.Scope.Base.WithKind

+ Agda.Syntax.Scope.Base: instance GHC.Base.Functor Agda.Syntax.Scope.Base.WithKind

+ Agda.Syntax.Scope.Base: instance GHC.Base.Semigroup Agda.Syntax.Scope.Base.NameMapEntry

+ Agda.Syntax.Scope.Base: instance GHC.Classes.Eq Agda.Syntax.Scope.Base.DataOrRecordModule

+ Agda.Syntax.Scope.Base: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Syntax.Scope.Base.WithKind a)

+ Agda.Syntax.Scope.Base: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Syntax.Scope.Base.WithKind a)

+ Agda.Syntax.Scope.Base: instance GHC.Enum.Bounded Agda.Syntax.Scope.Base.DataOrRecordModule

+ Agda.Syntax.Scope.Base: instance GHC.Enum.Enum Agda.Syntax.Scope.Base.DataOrRecordModule

+ 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.BindingSource

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.DataOrRecordModule

+ 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.LocalVar

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.NameMapEntry

+ 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.NameOrModule

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.NameSpace

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.NameSpaceId

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.ResolvedName

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.Scope

+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.ScopeInfo

+ 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.DataOrRecordModule

+ Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.NameMapEntry

+ Agda.Syntax.Scope.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.Syntax.Scope.Base.WithKind a)

+ Agda.Syntax.Scope.Base: inverseScopeLookupModule' :: AllowAmbiguousNames -> ModuleName -> ScopeInfo -> [QName]

+ Agda.Syntax.Scope.Base: inverseScopeLookupName'' :: AllowAmbiguousNames -> QName -> ScopeInfo -> Maybe NameMapEntry

+ Agda.Syntax.Scope.Base: isConName :: KindOfName -> Maybe Induction

+ Agda.Syntax.Scope.Base: isNameInScopeUnqualified :: QName -> ScopeInfo -> Bool

+ Agda.Syntax.Scope.Base: withoutPrivates :: ScopeInfo -> ScopeInfo

+ Agda.Syntax.Scope.Monad: bindName'' :: Access -> KindOfName -> NameMetadata -> Name -> QName -> ScopeM (Maybe TypeError)

+ Agda.Syntax.Scope.Monad: canHaveSuffixTest :: HasBuiltins m => m (QName -> Bool)

+ Agda.Syntax.Scope.Monad: scopeWarning :: HasCallStack => DeclarationWarning' -> ScopeM ()

+ Agda.Syntax.Scope.Monad: scopeWarning' :: CallStack -> DeclarationWarning' -> ScopeM ()

+ Agda.Syntax.Scope.Monad: verifyImportDirective :: [ImportedName] -> HidingDirective -> RenamingDirective -> ScopeM ()

+ Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a, Agda.Syntax.Translation.AbstractToConcrete.ConOfAbs a GHC.Types.~ Agda.Syntax.Concrete.LHS) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Abstract.Clause' a)

+ Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a1, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a2) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Data.Either.Either a1 a2)

+ Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a1, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a2, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a3) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (a1, a2, a3)

+ Agda.Syntax.Translation.AbstractToConcrete: instance (Agda.Syntax.Translation.AbstractToConcrete.ToConcrete p, Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a) => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Common.RewriteEqn' qn Agda.Syntax.Abstract.BindName p a)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.Syntax.Translation.AbstractToConcrete.AbsToCon

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete ()

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Common.Constr Agda.Syntax.Abstract.Constructor)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.SplitPattern (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern))

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.SplitPattern Agda.Syntax.Abstract.Pattern)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.UserPattern (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Pattern))

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Translation.AbstractToConcrete.UserPattern Agda.Syntax.Abstract.Pattern)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (GHC.Maybe.Maybe Agda.Syntax.Abstract.BindName)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (GHC.Maybe.Maybe Agda.Syntax.Abstract.Name.QName)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (GHC.Maybe.Maybe Agda.Syntax.Abstract.Pattern)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.BindName

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Declaration

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Expr

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LHS

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LHSCore

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LamBinding

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.LetBinding

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.ModuleApplication

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.ModuleName

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.Name

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Name.QName

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.Pattern

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.RHS

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.SpineLHS

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.TypedBinding

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Abstract.WhereDeclarations

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Common.InteractionId

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Scope.Base.AbstractName

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Scope.Base.ResolvedName

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Translation.AbstractToConcrete.BindingPattern

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Translation.AbstractToConcrete.FreshenName

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.Syntax.Translation.AbstractToConcrete.RangeAndPragma

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete Agda.TypeChecking.Monad.Base.NamedMeta

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete GHC.Types.Bool

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Abstract.Binder' a)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Syntax.Common.Arg a)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Syntax.Translation.AbstractToConcrete.ToConcrete a => Agda.Syntax.Translation.AbstractToConcrete.ToConcrete [a]

+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins Agda.Syntax.Translation.AbstractToConcrete.AbsToCon

+ Agda.Syntax.Translation.AbstractToConcrete: lookupQName :: AllowAmbiguousNames -> QName -> AbsToCon QName

+ Agda.Syntax.Translation.AbstractToConcrete: type family ConOfAbs a;

+ Agda.Syntax.Translation.AbstractToConcrete: }

+ Agda.Syntax.Translation.ConcreteToAbstract: importPrimitives :: ScopeM [Declaration]

+ Agda.Syntax.Translation.ConcreteToAbstract: instance (Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c1, Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c2) => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Data.Either.Either c1 c2)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance (Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c1, Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c2, Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c3) => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (c1, c2, c3)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract ()

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Abstract.LHSCore' Agda.Syntax.Concrete.Expr)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Abstract.Pattern' Agda.Syntax.Concrete.Expr)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Common.RewriteEqn' () Agda.Syntax.Abstract.BindName Agda.Syntax.Abstract.Pattern Agda.Syntax.Abstract.Expr)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Concrete.Binder' (Agda.Syntax.Translation.ConcreteToAbstract.NewName Agda.Syntax.Concrete.BoundName))

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.NewName Agda.Syntax.Concrete.BoundName)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.NewName Agda.Syntax.Concrete.Name.Name)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Translation.ConcreteToAbstract.TopLevel [Agda.Syntax.Concrete.Declaration])

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Definitions.Types.Clause

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Expr

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.HoleContent

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.LHSCore

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.LamBinding

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.ModuleAssignment

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Pattern

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.Pragma

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.RHS

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.RewriteEqn

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Concrete.TypedBinding

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.AbstractRHS

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.DataConstrDecl

+ 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.GenTel

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.GenTelAndType

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LeftHandSide

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LetDef

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.LetDefs

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.MaybeOldQName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.NewModuleName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.NewModuleQName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.OldModuleName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.OldQName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.PatName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.RecordConstructorType

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.ResolveQName

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract Agda.Syntax.Translation.ConcreteToAbstract.RightHandSide

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Common.Arg c)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Syntax.Common.Named name c)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (Agda.Utils.List1.List1 c)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract (GHC.Maybe.Maybe c)

+ Agda.Syntax.Translation.ConcreteToAbstract: instance Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract c => Agda.Syntax.Translation.ConcreteToAbstract.ToAbstract [c]

+ 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.ConcreteToAbstract: type family AbsOfCon c;

+ Agda.Syntax.Translation.ConcreteToAbstract: }

+ Agda.Syntax.Translation.InternalToAbstract: instance (Agda.Syntax.Translation.InternalToAbstract.Reify i1, Agda.Syntax.Translation.InternalToAbstract.Reify i2, Agda.Syntax.Translation.InternalToAbstract.Reify i3) => Agda.Syntax.Translation.InternalToAbstract.Reify (i1, i2, i3)

+ Agda.Syntax.Translation.InternalToAbstract: instance (Agda.Syntax.Translation.InternalToAbstract.Reify i1, Agda.Syntax.Translation.InternalToAbstract.Reify i2, Agda.Syntax.Translation.InternalToAbstract.Reify i3, Agda.Syntax.Translation.InternalToAbstract.Reify i4) => Agda.Syntax.Translation.InternalToAbstract.Reify (i1, i2, i3, i4)

+ 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.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Binder a => Agda.Syntax.Translation.InternalToAbstract.Binder (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.BlankVars a => Agda.Syntax.Translation.InternalToAbstract.BlankVars (Agda.Utils.List1.List1 a)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Internal.Clause)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Abstract.Name.QNamed Agda.TypeChecking.Monad.Base.System)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Abstract.Expr

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Abstract.Name.Name

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Common.MetaId

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Level

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Sort

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Telescope

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Term

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Internal.Type

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Literal.Literal

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.Syntax.Translation.InternalToAbstract.NamedClause

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify Agda.TypeChecking.Monad.Base.DisplayTerm

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify GHC.Types.Bool

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Common.Arg i)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Common.Named n i)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Internal.Dom i)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i => Agda.Syntax.Translation.InternalToAbstract.Reify (Agda.Syntax.Internal.Elim.Elim' i)

+ Agda.Syntax.Translation.InternalToAbstract: instance Agda.Syntax.Translation.InternalToAbstract.Reify i => Agda.Syntax.Translation.InternalToAbstract.Reify [i]

+ Agda.Syntax.Translation.InternalToAbstract: type family ReifiesTo i;

+ Agda.Syntax.Translation.InternalToAbstract: }

+ Agda.Syntax.Translation.ReflectedToAbstract: annotatePattern :: MonadReflectedToAbstract m => Int -> Type -> Pattern -> m Pattern

+ Agda.Syntax.Translation.ReflectedToAbstract: askVar :: MonadReflectedToAbstract m => Int -> m (Maybe (Name, Type))

+ Agda.Syntax.Translation.ReflectedToAbstract: checkClauseTelescopeBindings :: MonadReflectedToAbstract m => [(Text, Arg Type)] -> [Arg Pattern] -> m ()

+ Agda.Syntax.Translation.ReflectedToAbstract: instance (Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract r, Agda.Syntax.Translation.ReflectedToAbstract.AbsOfRef r GHC.Types.~ Agda.Syntax.Abstract.Expr) => Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Internal.Dom r, Agda.Syntax.Abstract.Name.Name)

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Abstract.Expr, Agda.Syntax.Reflected.Elim)

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Abstract.Expr, Agda.Syntax.Reflected.Elims)

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Reflected.Clause)

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Utils.List1.List1 (Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Reflected.Clause))

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Literal.Literal

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Reflected.Pattern

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Reflected.Sort

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract Agda.Syntax.Reflected.Term

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract [Agda.Syntax.Abstract.Name.QNamed Agda.Syntax.Reflected.Clause]

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract r => Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Common.Arg r)

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract r => Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract (Agda.Syntax.Common.Named name r)

+ Agda.Syntax.Translation.ReflectedToAbstract: instance Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract r => Agda.Syntax.Translation.ReflectedToAbstract.ToAbstract [Agda.Syntax.Common.Arg r]

+ Agda.Syntax.Translation.ReflectedToAbstract: mkApp :: Expr -> Expr -> Expr

+ Agda.Syntax.Translation.ReflectedToAbstract: mkVar :: MonadReflectedToAbstract m => Int -> m (Name, Type)

+ Agda.Syntax.Translation.ReflectedToAbstract: mkVarName :: MonadReflectedToAbstract m => Int -> m Name

+ Agda.Syntax.Translation.ReflectedToAbstract: type Vars = [(Name, Type)]

+ Agda.Syntax.Translation.ReflectedToAbstract: type family AbsOfRef r;

+ Agda.Syntax.Translation.ReflectedToAbstract: withNames :: MonadReflectedToAbstract m => [String] -> ([Name] -> m a) -> m a

+ Agda.Syntax.Translation.ReflectedToAbstract: withVar :: MonadReflectedToAbstract m => String -> Type -> (Name -> m a) -> m a

+ Agda.Syntax.Translation.ReflectedToAbstract: withVars :: MonadReflectedToAbstract m => [(String, Type)] -> ([Name] -> m a) -> m a

+ Agda.Syntax.Translation.ReflectedToAbstract: }

+ Agda.Syntax.Treeless: ArgUnused :: ArgUsage

+ Agda.Syntax.Treeless: ArgUsed :: ArgUsage

+ Agda.Syntax.Treeless: TMeta :: String -> TError

+ Agda.Syntax.Treeless: data ArgUsage

+ Agda.Syntax.Treeless: filterUsed :: [ArgUsage] -> [a] -> [a]

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.ArgUsage

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.CaseInfo

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.CaseType

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.Compiled

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.TAlt

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.TError

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.TPrim

+ Agda.Syntax.Treeless: instance Control.DeepSeq.NFData Agda.Syntax.Treeless.TTerm

+ Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.ArgUsage

+ Agda.Syntax.Treeless: instance GHC.Classes.Eq Agda.Syntax.Treeless.ArgUsage

+ Agda.Syntax.Treeless: instance GHC.Classes.Ord Agda.Syntax.Treeless.ArgUsage

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.ArgUsage

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.CaseInfo

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.CaseType

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.Compiled

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.TAlt

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.TError

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.TPrim

+ Agda.Syntax.Treeless: instance GHC.Generics.Generic Agda.Syntax.Treeless.TTerm

+ Agda.Syntax.Treeless: instance GHC.Show.Show Agda.Syntax.Treeless.ArgUsage

+ Agda.Termination.CallGraph: instance Agda.Utils.Singleton.Collection (Agda.Termination.CallGraph.Call cinfo) (Agda.Termination.CallGraph.CallGraph cinfo)

+ Agda.Termination.CallGraph: instance Agda.Utils.Singleton.Singleton (Agda.Termination.CallGraph.Call cinfo) (Agda.Termination.CallGraph.CallGraph cinfo)

+ Agda.Termination.CutOff: defaultCutOff :: CutOff

+ Agda.Termination.CutOff: instance Control.DeepSeq.NFData Agda.Termination.CutOff.CutOff

+ Agda.Termination.Monad: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.Termination.Monad.TerM

+ Agda.Termination.Monad: instance Agda.TypeChecking.Monad.Pure.PureTCM Agda.Termination.Monad.TerM

+ Agda.Termination.Monad: instance Agda.Utils.Benchmark.MonadBench Agda.Termination.Monad.TerM

+ Agda.Termination.TermCheck: instance (Agda.Termination.TermCheck.ExtractCalls a, Agda.Termination.TermCheck.ExtractCalls b, Agda.Termination.TermCheck.ExtractCalls c) => Agda.Termination.TermCheck.ExtractCalls (a, b, c)

+ Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.ExtractCalls a => Agda.Termination.TermCheck.ExtractCalls (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Abstract: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Abstract.EqualSy a) => Agda.TypeChecking.Abstract.EqualSy (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Abstract: instance (Agda.TypeChecking.Substitute.Class.TermSubst a, Agda.TypeChecking.Abstract.AbsTerm a) => Agda.TypeChecking.Abstract.AbsTerm (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.AbsTerm a => Agda.TypeChecking.Abstract.AbsTerm (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Abstract: instance Agda.TypeChecking.Abstract.EqualSy a => Agda.TypeChecking.Abstract.EqualSy (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.CheckInternal: [elimViewAction] :: Action m -> Term -> m Term

+ Agda.TypeChecking.CheckInternal: [modalityAction] :: Action m -> Modality -> Modality -> Modality

+ Agda.TypeChecking.CheckInternal: checkInternalType' :: MonadCheckInternal m => Action m -> Type -> m Type

+ Agda.TypeChecking.CheckInternal: inferSpine' :: MonadCheckInternal m => Action m -> Type -> Term -> Term -> Elims -> m ((Term, Term), Type)

+ Agda.TypeChecking.CompiledClause: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.CompiledClause.Case a)

+ Agda.TypeChecking.CompiledClause: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.CompiledClause.CompiledClauses' a)

+ Agda.TypeChecking.CompiledClause: instance Control.DeepSeq.NFData c => Control.DeepSeq.NFData (Agda.TypeChecking.CompiledClause.WithArity c)

+ Agda.TypeChecking.CompiledClause: instance GHC.Generics.Generic (Agda.TypeChecking.CompiledClause.Case c)

+ Agda.TypeChecking.CompiledClause: instance GHC.Generics.Generic (Agda.TypeChecking.CompiledClause.CompiledClauses' a)

+ Agda.TypeChecking.CompiledClause: instance GHC.Generics.Generic (Agda.TypeChecking.CompiledClause.WithArity c)

+ Agda.TypeChecking.CompiledClause: prettyMap_ :: (Pretty k, Pretty v) => Map k v -> [Doc]

+ 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.Conversion: blockOnError :: MonadError TCErr m => Blocker -> m a -> m a

+ 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 (Agda.TypeChecking.Monad.Pure.PureTCM m, Agda.TypeChecking.Monad.Base.MonadBlock 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.Base.MonadBlock 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.Base.MonadBlock 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.Monad.Base.MonadBlock m) => Agda.TypeChecking.Warnings.MonadWarning (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

+ 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 Control.Monad.Trans.Class.MonadTrans Agda.TypeChecking.Conversion.Pure.PureConversionT

+ 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.ProblemId (Agda.TypeChecking.Conversion.Pure.PureConversionT m)

+ Agda.TypeChecking.Conversion.Pure: pureEqualType :: (PureTCM m, MonadBlock m) => Type -> Type -> m Bool

+ Agda.TypeChecking.Coverage.Match: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Coverage.Match.SplitPattern

+ Agda.TypeChecking.Coverage.SplitTree: instance Control.DeepSeq.NFData Agda.TypeChecking.Coverage.SplitTree.LazySplit

+ Agda.TypeChecking.Coverage.SplitTree: instance Control.DeepSeq.NFData Agda.TypeChecking.Coverage.SplitTree.SplitTag

+ Agda.TypeChecking.Coverage.SplitTree: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.Coverage.SplitTree.SplitTree' a)

+ Agda.TypeChecking.Coverage.SplitTree: instance GHC.Generics.Generic (Agda.TypeChecking.Coverage.SplitTree.SplitTree' a)

+ Agda.TypeChecking.Coverage.SplitTree: instance GHC.Generics.Generic Agda.TypeChecking.Coverage.SplitTree.LazySplit

+ Agda.TypeChecking.Coverage.SplitTree: instance GHC.Generics.Generic Agda.TypeChecking.Coverage.SplitTree.SplitTag

+ Agda.TypeChecking.Datatypes: getNotErasedConstructors :: QName -> TCM [QName]

+ Agda.TypeChecking.DisplayForm: instance (Agda.TypeChecking.DisplayForm.SubstWithOrigin a, Agda.TypeChecking.DisplayForm.SubstWithOrigin (Agda.Syntax.Common.Arg a)) => Agda.TypeChecking.DisplayForm.SubstWithOrigin (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.DisplayForm: instance Agda.TypeChecking.DisplayForm.Match a => Agda.TypeChecking.DisplayForm.Match (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Errors: applyFlagsToTCWarningsPreserving :: HasOptions m => Set WarningName -> [TCWarning] -> m [TCWarning]

+ Agda.TypeChecking.Errors: getAllUnsolvedWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => m [TCWarning]

+ Agda.TypeChecking.Errors: getAllWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => WhichWarnings -> m [TCWarning]

+ Agda.TypeChecking.Errors: getAllWarningsOfTCErr :: TCErr -> TCM [TCWarning]

+ Agda.TypeChecking.Errors: getAllWarningsPreserving :: (MonadFail m, ReadTCState m, MonadWarning m) => Set WarningName -> WhichWarnings -> m [TCWarning]

+ Agda.TypeChecking.Forcing: instance Agda.TypeChecking.Forcing.ForcedVariables a => Agda.TypeChecking.Forcing.ForcedVariables (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Free: freeVarsIgnore :: (IsVarSet a c, Singleton Variable c, Free t) => IgnoreSorts -> t -> c

+ 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.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.Precompute: instance Agda.TypeChecking.Free.Precompute.PrecomputeFreeVars a => Agda.TypeChecking.Free.Precompute.PrecomputeFreeVars (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Free.Reduce: instance (Agda.TypeChecking.Reduce.Reduce a, Agda.TypeChecking.Free.Reduce.ForceNotFree a) => Agda.TypeChecking.Free.Reduce.ForceNotFree (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Free.Reduce: instance (Agda.TypeChecking.Reduce.Reduce a, Agda.TypeChecking.Free.Reduce.ForceNotFree a, Agda.TypeChecking.Substitute.Class.TermSubst a) => Agda.TypeChecking.Free.Reduce.ForceNotFree (Agda.Syntax.Internal.Dom a)

+ Agda.TypeChecking.Implicit: insertImplicitBindersT :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m) => [NamedArg Binder] -> Type -> m [NamedArg Binder]

+ Agda.TypeChecking.Implicit: insertImplicitBindersT1 :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m) => List1 (NamedArg Binder) -> Type -> m (List1 (NamedArg Binder))

+ Agda.TypeChecking.Irrelevance: instance (Agda.TypeChecking.Irrelevance.UsableRelevance a, Agda.TypeChecking.Irrelevance.UsableRelevance b, Agda.TypeChecking.Irrelevance.UsableRelevance c) => Agda.TypeChecking.Irrelevance.UsableRelevance (a, b, c)

+ Agda.TypeChecking.Irrelevance: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Irrelevance.UsableRelevance a) => Agda.TypeChecking.Irrelevance.UsableRelevance (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Irrelevance: instance Agda.TypeChecking.Irrelevance.UsableModality a => Agda.TypeChecking.Irrelevance.UsableModality (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Irrelevance: instance Agda.TypeChecking.Irrelevance.UsableRelevance a => Agda.TypeChecking.Irrelevance.UsableRelevance (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Irrelevance: isCoFibrantSort :: (LensSort a, PureTCM m, MonadBlock m) => a -> m Bool

+ Agda.TypeChecking.Irrelevance: isFibrant :: (LensSort a, PureTCM m, MonadBlock m) => a -> m Bool

+ Agda.TypeChecking.Irrelevance: usableAtModality :: MonadConstraint TCM => Modality -> Term -> TCM ()

+ 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.Level: data SingleLevel' t

+ Agda.TypeChecking.Level: instance Agda.TypeChecking.Free.Lazy.Free t => Agda.TypeChecking.Free.Lazy.Free (Agda.TypeChecking.Level.SingleLevel' t)

+ Agda.TypeChecking.Level: instance Agda.TypeChecking.Substitute.Class.Subst t => Agda.TypeChecking.Substitute.Class.Subst (Agda.TypeChecking.Level.SingleLevel' t)

+ Agda.TypeChecking.Level: instance Data.Foldable.Foldable Agda.TypeChecking.Level.SingleLevel'

+ Agda.TypeChecking.Level: instance Data.Traversable.Traversable Agda.TypeChecking.Level.SingleLevel'

+ Agda.TypeChecking.Level: instance GHC.Base.Functor Agda.TypeChecking.Level.SingleLevel'

+ Agda.TypeChecking.Level: instance GHC.Show.Show t => GHC.Show.Show (Agda.TypeChecking.Level.SingleLevel' t)

+ Agda.TypeChecking.Level: type SingleLevel = SingleLevel' Term

+ Agda.TypeChecking.Lock: checkEarlierThan :: Term -> VarSet -> TCM ()

+ Agda.TypeChecking.Lock: checkLockedVars :: Term -> Type -> Arg Term -> Type -> TCM ()

+ Agda.TypeChecking.Lock: isTimeless :: Type -> TCM Bool

+ Agda.TypeChecking.Lock: requireGuarded :: String -> TCM ()

+ Agda.TypeChecking.MetaVars: ProjVar :: ProjectedVar -> InvertExcept

+ Agda.TypeChecking.MetaVars: hasTwinMeta :: MetaId -> TCM Bool

+ Agda.TypeChecking.MetaVars.Mention: instance Agda.TypeChecking.MetaVars.Mention.MentionsMeta Agda.Syntax.Internal.Blockers.Blocker

+ Agda.TypeChecking.MetaVars.Occurs: instance (Agda.TypeChecking.MetaVars.Occurs.Occurs a, Agda.TypeChecking.MetaVars.Occurs.Occurs b, Agda.TypeChecking.MetaVars.Occurs.Occurs c) => Agda.TypeChecking.MetaVars.Occurs.Occurs (a, b, c)

+ Agda.TypeChecking.MetaVars.Occurs: instance (Agda.TypeChecking.MetaVars.Occurs.Occurs a, Agda.TypeChecking.Substitute.Class.Subst a) => Agda.TypeChecking.MetaVars.Occurs.Occurs (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.MetaVars.Occurs: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.MetaVars.Occurs.AnyRigid a) => Agda.TypeChecking.MetaVars.Occurs.AnyRigid (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.AnyRigid a => Agda.TypeChecking.MetaVars.Occurs.AnyRigid (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.MetaVars.Occurs: instance Agda.TypeChecking.MetaVars.Occurs.Occurs a => Agda.TypeChecking.MetaVars.Occurs.Occurs (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.MetaVars.Occurs: metaCheck :: MetaId -> OccursM MetaId

+ Agda.TypeChecking.Monad.Base: ACState :: [Maybe Range] -> Elims -> [Maybe (Abs Constraint)] -> Type -> a -> ArgsCheckState a

+ Agda.TypeChecking.Monad.Base: AsPatternShadowsConstructorOrPatternSynonym :: Bool -> Warning

+ Agda.TypeChecking.Monad.Base: BlockT :: ExceptT Blocker m a -> BlockT m a

+ Agda.TypeChecking.Monad.Base: BlockedType :: Blocker -> Closure Type -> SplitError

+ Agda.TypeChecking.Monad.Base: BuiltinSort :: String -> BuiltinDescriptor

+ Agda.TypeChecking.Monad.Base: CheckLockedVars :: Term -> Type -> Arg Term -> Type -> Constraint

+ Agda.TypeChecking.Monad.Base: CheckPatternLinearityType :: Name -> Call

+ Agda.TypeChecking.Monad.Base: CheckPatternLinearityValue :: Name -> Call

+ Agda.TypeChecking.Monad.Base: DisambiguatedName :: NameKind -> QName -> DisambiguatedName

+ Agda.TypeChecking.Monad.Base: DontReduceDefs :: Set QName -> ReduceDefs

+ Agda.TypeChecking.Monad.Base: DuplicateFieldsWarning :: [(Name, Range)] -> RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: DuplicateUsing :: List1 ImportedName -> Warning

+ Agda.TypeChecking.Monad.Base: EmptyWhere :: Warning

+ Agda.TypeChecking.Monad.Base: GenericUseless :: Range -> Doc -> Warning

+ Agda.TypeChecking.Monad.Base: GlobalCandidate :: QName -> CandidateKind

+ Agda.TypeChecking.Monad.Base: LocalCandidate :: CandidateKind

+ Agda.TypeChecking.Monad.Base: ModuleScopeChecked :: ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: ModuleTypeChecked :: ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: NeedOptionTwoLevel :: TypeError

+ Agda.TypeChecking.Monad.Base: NoGuardednessFlag :: QName -> Warning

+ Agda.TypeChecking.Monad.Base: OnlyReduceDefs :: Set QName -> ReduceDefs

+ Agda.TypeChecking.Monad.Base: PLockUniv :: NLPSort

+ Agda.TypeChecking.Monad.Base: PrimitiveSort :: String -> Sort -> Defn

+ Agda.TypeChecking.Monad.Base: PrincipalArgTypeMetas :: Args -> Type -> PrincipalArgTypeMetas

+ Agda.TypeChecking.Monad.Base: RecordFieldWarning :: RecordFieldWarning -> Warning

+ Agda.TypeChecking.Monad.Base: RewriteAmbiguousRules :: Term -> Term -> Term -> Warning

+ Agda.TypeChecking.Monad.Base: RewriteMissingRule :: Term -> Term -> Term -> Warning

+ Agda.TypeChecking.Monad.Base: SortOfSplitVarError :: Maybe Blocker -> Doc -> TypeError

+ Agda.TypeChecking.Monad.Base: SplitOnNonEtaRecord :: QName -> TypeError

+ Agda.TypeChecking.Monad.Base: TooManyFieldsWarning :: QName -> [Name] -> [(Name, Range)] -> RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: UsableAtModality :: Modality -> Term -> Constraint

+ Agda.TypeChecking.Monad.Base: UselessHiding :: [ImportedName] -> Warning

+ Agda.TypeChecking.Monad.Base: UselessPatternDeclarationForRecord :: String -> Warning

+ Agda.TypeChecking.Monad.Base: WrongModalityForPrimitive :: String -> ArgInfo -> ArgInfo -> TypeError

+ Agda.TypeChecking.Monad.Base: YesGeneralizeMeta :: DoGeneralize

+ Agda.TypeChecking.Monad.Base: YesGeneralizeVar :: DoGeneralize

+ Agda.TypeChecking.Monad.Base: [acConstraints] :: ArgsCheckState a -> [Maybe (Abs Constraint)]

+ Agda.TypeChecking.Monad.Base: [acData] :: ArgsCheckState a -> a

+ Agda.TypeChecking.Monad.Base: [acElims] :: ArgsCheckState a -> Elims

+ Agda.TypeChecking.Monad.Base: [acRanges] :: ArgsCheckState a -> [Maybe Range]

+ Agda.TypeChecking.Monad.Base: [acType] :: ArgsCheckState a -> Type

+ Agda.TypeChecking.Monad.Base: [axiomConstTransp] :: Defn -> Bool

+ Agda.TypeChecking.Monad.Base: [candidateKind] :: Candidate -> CandidateKind

+ Agda.TypeChecking.Monad.Base: [cantSplitBlocker] :: SplitError -> Maybe Blocker

+ Agda.TypeChecking.Monad.Base: [constraintUnblocker] :: ProblemConstraint -> Blocker

+ Agda.TypeChecking.Monad.Base: [dfPatternVars] :: DisplayForm -> Nat

+ Agda.TypeChecking.Monad.Base: [envConflComputingOverlap] :: TCEnv -> Bool

+ Agda.TypeChecking.Monad.Base: [envReconstructed] :: TCEnv -> Bool

+ Agda.TypeChecking.Monad.Base: [envReduceDefs] :: TCEnv -> ReduceDefs

+ Agda.TypeChecking.Monad.Base: [envSplitOnStrict] :: TCEnv -> Bool

+ Agda.TypeChecking.Monad.Base: [extLamAbsurd] :: ExtLamInfo -> Bool

+ Agda.TypeChecking.Monad.Base: [iDefaultPragmaOptions] :: Interface -> [OptionsPragma]

+ Agda.TypeChecking.Monad.Base: [iFilePragmaOptions] :: Interface -> [OptionsPragma]

+ Agda.TypeChecking.Monad.Base: [miModality] :: MetaInfo -> Modality

+ Agda.TypeChecking.Monad.Base: [miMode] :: ModuleInfo -> ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: [openThingCheckpointMap] :: Open a -> Map CheckpointId Substitution

+ Agda.TypeChecking.Monad.Base: [openThingModule] :: Open a -> ModuleNameHash

+ Agda.TypeChecking.Monad.Base: [patmMetas] :: PrincipalArgTypeMetas -> Args

+ Agda.TypeChecking.Monad.Base: [patmRemainder] :: PrincipalArgTypeMetas -> Type

+ Agda.TypeChecking.Monad.Base: [primSort] :: Defn -> Sort

+ Agda.TypeChecking.Monad.Base: [recPatternMatching] :: Defn -> PatternOrCopattern

+ Agda.TypeChecking.Monad.Base: [rewFromClause] :: RewriteRule -> Bool

+ Agda.TypeChecking.Monad.Base: [stPreAgdaLibFiles] :: PreScopeState -> !Map FilePath AgdaLibFile

+ Agda.TypeChecking.Monad.Base: [stPreProjectConfigs] :: PreScopeState -> !Map FilePath ProjectConfig

+ Agda.TypeChecking.Monad.Base: [tcErrLocation] :: TCErr -> CallStack

+ Agda.TypeChecking.Monad.Base: [tcWarningLocation] :: TCWarning -> CallStack

+ Agda.TypeChecking.Monad.Base: [unBlockT] :: BlockT m a -> ExceptT Blocker m a

+ Agda.TypeChecking.Monad.Base: beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a

+ Agda.TypeChecking.Monad.Base: catchPatternErr :: MonadBlock m => (Blocker -> m a) -> m a -> m a

+ Agda.TypeChecking.Monad.Base: class Monad m => MonadBlock m

+ Agda.TypeChecking.Monad.Base: constTranspAxiom :: Defn

+ Agda.TypeChecking.Monad.Base: data ArgsCheckState a

+ Agda.TypeChecking.Monad.Base: data CandidateKind

+ Agda.TypeChecking.Monad.Base: data DisambiguatedName

+ Agda.TypeChecking.Monad.Base: data ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: data PrincipalArgTypeMetas

+ Agda.TypeChecking.Monad.Base: data RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: data ReduceDefs

+ Agda.TypeChecking.Monad.Base: defaultAxiom :: Defn

+ Agda.TypeChecking.Monad.Base: eConflComputingOverlap :: Lens' Bool TCEnv

+ Agda.TypeChecking.Monad.Base: eReconstructed :: Lens' Bool TCEnv

+ Agda.TypeChecking.Monad.Base: eReduceDefs :: Lens' ReduceDefs TCEnv

+ Agda.TypeChecking.Monad.Base: eSplitOnStrict :: Lens' Bool TCEnv

+ Agda.TypeChecking.Monad.Base: instance (Control.Monad.IO.Class.MonadIO m, Agda.Utils.Null.Null a) => Agda.Utils.Null.Null (Agda.TypeChecking.Monad.Base.TCMT m a)

+ Agda.TypeChecking.Monad.Base: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.TypeChecking.Monad.Base.ReduceM

+ Agda.TypeChecking.Monad.Base: instance Agda.Interaction.Options.HasOptions.HasOptions m => Agda.Interaction.Options.HasOptions.HasOptions (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.CopatternMatchingAllowed Agda.TypeChecking.Monad.Base.EtaEquality

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.Monad.Base.MetaInfo

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.Monad.Base.MetaVariable

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensQuantity Agda.TypeChecking.Monad.Base.MetaInfo

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensQuantity Agda.TypeChecking.Monad.Base.MetaVariable

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.PatternMatchingAllowed Agda.TypeChecking.Monad.Base.EtaEquality

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Elim.IsProjElim e => Agda.Syntax.Internal.Elim.IsProjElim (Agda.TypeChecking.Monad.Base.MaybeReduced e)

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.TypeChecking.Monad.Base.CompareAs

+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.TypeChecking.Monad.Base.Constraint

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.HasFresh Agda.Syntax.Common.ProblemId

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadBlock Agda.TypeChecking.Monad.Base.TCM

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadBlock m => Agda.TypeChecking.Monad.Base.MonadBlock (Control.Monad.Trans.Maybe.MaybeT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadBlock m => Agda.TypeChecking.Monad.Base.MonadBlock (Control.Monad.Trans.Reader.ReaderT e m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadFresh i m => Agda.TypeChecking.Monad.Base.MonadFresh i (Agda.Utils.ListT.ListT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadFresh i m => Agda.TypeChecking.Monad.Base.MonadFresh i (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadReduce m => Agda.TypeChecking.Monad.Base.MonadReduce (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadReduce m => Agda.TypeChecking.Monad.Base.MonadReduce (Agda.Utils.Update.ChangeT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadReduce m => Agda.TypeChecking.Monad.Base.MonadReduce (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadStConcreteNames m => Agda.TypeChecking.Monad.Base.MonadStConcreteNames (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCEnv m => Agda.TypeChecking.Monad.Base.MonadTCEnv (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCM m => Agda.TypeChecking.Monad.Base.MonadTCM (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.MonadTCState m => Agda.TypeChecking.Monad.Base.MonadTCState (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.ReadTCState (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.ReadTCState (Agda.Utils.Update.ChangeT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.TypeChecking.Monad.Base.ReadTCState m => Agda.TypeChecking.Monad.Base.ReadTCState (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Benchmark.MonadBench Agda.TypeChecking.Monad.Base.TCM

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.BiMap.HasTag Agda.TypeChecking.Monad.Base.InteractionPoint

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.DisplayForm

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.ProjLams

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.Projection

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (Agda.TypeChecking.Monad.Base.Judgement a)

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (Agda.TypeChecking.Monad.Base.Open a)

+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty c => Agda.Utils.Pretty.Pretty (Agda.TypeChecking.Monad.Base.FunctionInverse' c)

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.AbstractMode

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.AllowedReduction

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Call

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.CallInfo

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Candidate

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.CandidateKind

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.CheckpointId

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.CompKit

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.CompareAs

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Comparison

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.CompilerPragma

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Constraint

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Definition

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Defn

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.DisambiguatedName

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.DisplayForm

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.DisplayTerm

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.DoGeneralize

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.EtaEquality

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ExpandHidden

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ExtLamInfo

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ForeignCode

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Frozen

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.FunctionFlag

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.GeneralizedValue

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.HighlightingLevel

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.HighlightingMethod

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.IPClause

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.InteractionPoint

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.InteractionPoints

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Interface

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.IsForced

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.LHSOrPatSyn

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Listener

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.LoadedFileCache

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.MetaInfo

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.MetaInstantiation

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.MetaPriority

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.MetaVariable

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ModuleInfo

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.MutualBlock

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.MutualId

+ 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.NegativeUnification

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.NumGeneralizableArgs

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Overapplied

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PersistentTCState

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Polarity

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PostScopeState

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PreScopeState

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PrimFun

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PrincipalArgTypeMetas

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ProblemConstraint

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ProjLams

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Projection

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ReduceDefs

+ 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.RunMetaOccursCheck

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Section

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Signature

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Simplification

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.SplitError

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.System

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TCEnv

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TCErr

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TCState

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TCWarning

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TermHead

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TerminationError

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TypeCheckAction

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TypeCheckingProblem

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.TypeError

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.UnificationFailure

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.UnquoteError

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.UnquoteFlags

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Warning

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.Closure a)

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.Judgement a)

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.Open a)

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData c => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.FunctionInverse' c)

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData pf => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.Builtin pf)

+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData t => Control.DeepSeq.NFData (Agda.TypeChecking.Monad.Base.IPBoundary' t)

+ Agda.TypeChecking.Monad.Base: instance Control.Monad.Fail.MonadFail m => Control.Monad.Fail.MonadFail (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Control.Monad.IO.Class.MonadIO m => Agda.Interaction.Options.HasOptions.HasOptions (Agda.TypeChecking.Monad.Base.TCMT m)

+ Agda.TypeChecking.Monad.Base: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance Control.Monad.Trans.Class.MonadTrans Agda.TypeChecking.Monad.Base.BlockT

+ Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CandidateKind

+ Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ReduceDefs

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Functor m => GHC.Base.Functor (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadBlock (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Monad m => Agda.TypeChecking.Monad.Base.MonadBlock (Control.Monad.Trans.Except.ExceptT Agda.TypeChecking.Monad.Base.TCErr m)

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Monad m => GHC.Base.Applicative (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Monad m => GHC.Base.Monad (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Monoid Agda.TypeChecking.Monad.Base.ReduceDefs

+ Agda.TypeChecking.Monad.Base: instance GHC.Base.Semigroup Agda.TypeChecking.Monad.Base.ReduceDefs

+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Classes.Ord Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Enum.Bounded Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Enum.Enum Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.Builtin pf)

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.Closure a)

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.FunctionInverse' c)

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.IPBoundary' t)

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.Judgement a)

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic (Agda.TypeChecking.Monad.Base.Open a)

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.AbstractMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.AllowedReduction

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Call

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.CallInfo

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Candidate

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.CandidateKind

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.CompKit

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.CompareAs

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Comparison

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.CompilerPragma

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Constraint

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Definition

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Defn

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.DisambiguatedName

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.DisplayForm

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.DisplayTerm

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.DoGeneralize

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.EtaEquality

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ExpandHidden

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ExtLamInfo

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ForeignCode

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Frozen

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.FunctionFlag

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.GeneralizedValue

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.HighlightingLevel

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.HighlightingMethod

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.IPClause

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.InteractionPoint

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Interface

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.IsForced

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.LHSOrPatSyn

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Listener

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.LoadedFileCache

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.MetaInfo

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.MetaInstantiation

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.MetaVariable

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ModuleInfo

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.MutualBlock

+ 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.NegativeUnification

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Overapplied

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PersistentTCState

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Polarity

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PostScopeState

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PreScopeState

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PrimFun

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PrincipalArgTypeMetas

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ProblemConstraint

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ProjLams

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Projection

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ReduceDefs

+ 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.RunMetaOccursCheck

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Signature

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Simplification

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.SplitError

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.System

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TCEnv

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TCState

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TCWarning

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TermHead

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TerminationError

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TypeCheckAction

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TypeCheckingProblem

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.TypeError

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.UnificationFailure

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.UnquoteError

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.UnquoteFlags

+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Warning

+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.CandidateKind

+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.ModuleCheckMode

+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.RecordFieldWarning

+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Monad.Base.ArgsCheckState a)

+ Agda.TypeChecking.Monad.Base: isReconstructed :: MonadTCEnv m => m Bool

+ Agda.TypeChecking.Monad.Base: locallyReconstructed :: MonadTCEnv m => m a -> m a

+ Agda.TypeChecking.Monad.Base: locallyReduceAllDefs :: MonadTCEnv m => m a -> m a

+ Agda.TypeChecking.Monad.Base: locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a

+ Agda.TypeChecking.Monad.Base: locatedTypeError :: MonadTCError m => (a -> TypeError) -> HasCallStack => a -> m b

+ Agda.TypeChecking.Monad.Base: newtype BlockT m a

+ Agda.TypeChecking.Monad.Base: recordFieldWarningToError :: RecordFieldWarning -> TypeError

+ Agda.TypeChecking.Monad.Base: reduceAllDefs :: ReduceDefs

+ Agda.TypeChecking.Monad.Base: runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)

+ Agda.TypeChecking.Monad.Base: shouldReduceDef :: MonadTCEnv m => QName -> m Bool

+ Agda.TypeChecking.Monad.Base: stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState

+ Agda.TypeChecking.Monad.Base: stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState

+ Agda.TypeChecking.Monad.Base: thenReduce :: ReduceM a -> ReduceM b -> ReduceM b

+ Agda.TypeChecking.Monad.Base: type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)

+ Agda.TypeChecking.Monad.Base: typeError' :: MonadTCError m => CallStack -> TypeError -> m a

+ Agda.TypeChecking.Monad.Base: typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr

+ Agda.TypeChecking.Monad.Benchmark: type family BenchPhase m

+ Agda.TypeChecking.Monad.Builtin: SortKit :: QName -> QName -> QName -> (IsFibrant -> QName) -> SortKit

+ Agda.TypeChecking.Monad.Builtin: [nameOfProp] :: SortKit -> QName

+ Agda.TypeChecking.Monad.Builtin: [nameOfSSet] :: SortKit -> QName

+ Agda.TypeChecking.Monad.Builtin: [nameOfSetOmega] :: SortKit -> IsFibrant -> QName

+ Agda.TypeChecking.Monad.Builtin: [nameOfSet] :: SortKit -> QName

+ Agda.TypeChecking.Monad.Builtin: data SortKit

+ Agda.TypeChecking.Monad.Builtin: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins m => Agda.TypeChecking.Monad.Builtin.HasBuiltins (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Builtin: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins m => Agda.TypeChecking.Monad.Builtin.HasBuiltins (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Builtin: primAgdaSortInf :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaSortProp :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaSortPropLit :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMDontReduceDefs :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMExec :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMOnlyReduceDefs :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMQuoteOmegaTerm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMWithReconsParams :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primJust :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primLockUniv :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primMaybe :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primModality :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primModalityConstructor :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primNothing :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primProp :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primQuantity :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primQuantity0 :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primQuantityω :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primSSetOmega :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primSet :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: primStrictSet :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term

+ Agda.TypeChecking.Monad.Builtin: sortKit :: HasBuiltins m => m SortKit

+ Agda.TypeChecking.Monad.Constraints: addAndUnblocker :: MonadBlock m => Blocker -> m a -> m a

+ Agda.TypeChecking.Monad.Constraints: addOrUnblocker :: MonadBlock m => Blocker -> m a -> m a

+ Agda.TypeChecking.Monad.Constraints: instance Agda.TypeChecking.Monad.Constraints.MonadConstraint m => Agda.TypeChecking.Monad.Constraints.MonadConstraint (Control.Monad.Trans.Reader.ReaderT e m)

+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext (Agda.Utils.List1.List1 (Agda.Syntax.Common.Arg Agda.Syntax.Abstract.Name.Name), Agda.Syntax.Internal.Type)

+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext (Agda.Utils.List1.List1 (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Name.Name), Agda.Syntax.Internal.Type)

+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext (Agda.Utils.List1.List1 (Agda.Syntax.Common.WithHiding Agda.Syntax.Abstract.Name.Name), Agda.Syntax.Internal.Dom Agda.Syntax.Internal.Type)

+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext (Agda.Utils.List1.List1 Agda.Syntax.Abstract.Name.Name, Agda.Syntax.Internal.Dom Agda.Syntax.Internal.Type)

+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.MonadAddContext m => Agda.TypeChecking.Monad.Context.MonadAddContext (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.MonadAddContext m => Agda.TypeChecking.Monad.Context.MonadAddContext (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Debug: closeVerboseBracketException :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()

+ Agda.TypeChecking.Monad.Debug: defaultGetVerbosity :: HasOptions m => m Verbosity

+ Agda.TypeChecking.Monad.Debug: defaultIsDebugPrinting :: MonadTCEnv m => m Bool

+ Agda.TypeChecking.Monad.Debug: defaultNowDebugPrinting :: MonadTCEnv m => m a -> m a

+ Agda.TypeChecking.Monad.Debug: instance Agda.TypeChecking.Monad.Debug.MonadDebug m => Agda.TypeChecking.Monad.Debug.MonadDebug (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Imports: getPrettyVisitedModules :: ReadTCState m => m Doc

+ Agda.TypeChecking.Monad.MetaVars: getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]

+ Agda.TypeChecking.Monad.MetaVars: getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]

+ Agda.TypeChecking.Monad.MetaVars: getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]

+ Agda.TypeChecking.Monad.MetaVars: instance Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints m => Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.MetaVars: setMetaGeneralizableArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m ()

+ Agda.TypeChecking.Monad.Options: addTrustedExecutables :: CommandLineOptions -> TCM CommandLineOptions

+ Agda.TypeChecking.Monad.Options: getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]

+ Agda.TypeChecking.Monad.Options: getIncludeDirs :: HasOptions m => m [AbsolutePath]

+ Agda.TypeChecking.Monad.Options: getLibraryOptions :: FilePath -> TCM [OptionsPragma]

+ Agda.TypeChecking.Monad.Options: isTwoLevelEnabled :: HasOptions m => m Bool

+ Agda.TypeChecking.Monad.Options: showIdentitySubstitutions :: HasOptions m => m Bool

+ Agda.TypeChecking.Monad.Pure: class (HasBuiltins m, HasConstInfo m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadTCEnv m, ReadTCState m) => PureTCM m

+ Agda.TypeChecking.Monad.Pure: instance (Agda.TypeChecking.Monad.Pure.PureTCM m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Pure.PureTCM (Control.Monad.Trans.Writer.Lazy.WriterT w m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM Agda.TypeChecking.Monad.Base.TCM

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.Utils.ListT.ListT m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Control.Monad.Trans.Except.ExceptT e m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Control.Monad.Trans.Maybe.MaybeT m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Control.Monad.Trans.Reader.ReaderT r m)

+ Agda.TypeChecking.Monad.Pure: instance Agda.TypeChecking.Monad.Pure.PureTCM m => Agda.TypeChecking.Monad.Pure.PureTCM (Control.Monad.Trans.State.Lazy.StateT s m)

+ Agda.TypeChecking.Monad.Signature: instance Agda.TypeChecking.Monad.Signature.HasConstInfo m => Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.TypeChecking.Monad.Base.BlockT m)

+ Agda.TypeChecking.Monad.SizedTypes: ProjectedVar :: Int -> [(ProjOrigin, QName)] -> ProjectedVar

+ Agda.TypeChecking.Monad.SizedTypes: [prProjs] :: ProjectedVar -> [(ProjOrigin, QName)]

+ Agda.TypeChecking.Monad.SizedTypes: [pvIndex] :: ProjectedVar -> Int

+ Agda.TypeChecking.Monad.SizedTypes: data ProjectedVar

+ Agda.TypeChecking.Monad.SizedTypes: instance GHC.Classes.Eq Agda.TypeChecking.Monad.SizedTypes.ProjectedVar

+ Agda.TypeChecking.Monad.SizedTypes: instance GHC.Show.Show Agda.TypeChecking.Monad.SizedTypes.ProjectedVar

+ Agda.TypeChecking.Monad.SizedTypes: unviewProjectedVar :: ProjectedVar -> Term

+ Agda.TypeChecking.Monad.SizedTypes: viewProjectedVar :: Term -> Maybe ProjectedVar

+ Agda.TypeChecking.Monad.State: currentModuleNameHash :: ReadTCState m => m ModuleNameHash

+ Agda.TypeChecking.Monad.Trace: class (MonadTCEnv m, ReadTCState m) => MonadTrace m

+ Agda.TypeChecking.Monad.Trace: instance (Agda.TypeChecking.Monad.Trace.MonadTrace m, GHC.Base.Monoid w) => Agda.TypeChecking.Monad.Trace.MonadTrace (Control.Monad.Trans.Writer.Lazy.WriterT w m)

+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace Agda.TypeChecking.Monad.Base.TCM

+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace m => Agda.TypeChecking.Monad.Trace.MonadTrace (Control.Monad.Trans.Except.ExceptT e m)

+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace m => Agda.TypeChecking.Monad.Trace.MonadTrace (Control.Monad.Trans.Identity.IdentityT m)

+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace m => Agda.TypeChecking.Monad.Trace.MonadTrace (Control.Monad.Trans.Reader.ReaderT r m)

+ Agda.TypeChecking.Monad.Trace: instance Agda.TypeChecking.Monad.Trace.MonadTrace m => Agda.TypeChecking.Monad.Trace.MonadTrace (Control.Monad.Trans.State.Lazy.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.TypeChecking.Monad.Base.MonadReduce m) => Agda.TypeChecking.Monad.Pure.PureTCM (Agda.TypeChecking.Names.NamesT m)

+ Agda.TypeChecking.Names: instance Agda.Interaction.Options.HasOptions.HasOptions m => Agda.Interaction.Options.HasOptions.HasOptions (Agda.TypeChecking.Names.NamesT m)

+ Agda.TypeChecking.Names: instance Agda.TypeChecking.Monad.Signature.HasConstInfo m => Agda.TypeChecking.Monad.Signature.HasConstInfo (Agda.TypeChecking.Names.NamesT m)

+ Agda.TypeChecking.Patterns.Match: matchedArgs' :: Int -> IntMap (Arg a) -> [Maybe (Arg a)]

+ Agda.TypeChecking.Patterns.Match: type MonadMatch m = PureTCM m

+ Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity a => Agda.TypeChecking.Polarity.HasPolarity (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity a => Agda.TypeChecking.Polarity.HasPolarity (Agda.Syntax.Internal.Level' a)

+ Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity a => Agda.TypeChecking.Polarity.HasPolarity (Agda.Syntax.Internal.PlusLevel' a)

+ Agda.TypeChecking.Polarity: instance Agda.TypeChecking.Polarity.HasPolarity a => Agda.TypeChecking.Polarity.HasPolarity (Agda.Syntax.Internal.Type'' t a)

+ Agda.TypeChecking.Polarity: instance GHC.Base.Monad m => Agda.Utils.Singleton.Singleton Agda.TypeChecking.Monad.Base.Polarity (Agda.TypeChecking.Polarity.LeastPolarity m)

+ Agda.TypeChecking.Polarity: instance GHC.Base.Monad m => GHC.Base.Monoid (Agda.TypeChecking.Polarity.LeastPolarity m)

+ Agda.TypeChecking.Polarity: instance GHC.Base.Monad m => GHC.Base.Semigroup (Agda.TypeChecking.Polarity.LeastPolarity m)

+ 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.Pretty.PrettyTCMWithNode (Agda.TypeChecking.Positivity.Edge Agda.TypeChecking.Positivity.Occurrence.OccursWhere)

+ Agda.TypeChecking.Positivity: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Positivity.Item

+ 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.Generics.Generic Agda.TypeChecking.Positivity.Occurrence.OccursWhere

+ Agda.TypeChecking.Positivity.Occurrence: instance GHC.Generics.Generic Agda.TypeChecking.Positivity.Occurrence.Where

+ Agda.TypeChecking.Pretty: class PrettyTCMWithNode a

+ Agda.TypeChecking.Pretty: doubleQuotes :: Functor m => m Doc -> m Doc

+ Agda.TypeChecking.Pretty: instance (Agda.TypeChecking.Pretty.PrettyTCM n, Agda.TypeChecking.Pretty.PrettyTCMWithNode e) => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Utils.Graph.AdjacencyMap.Unidirectional.Graph n e)

+ Agda.TypeChecking.Pretty: instance (Agda.Utils.Pretty.Pretty a, Agda.TypeChecking.Pretty.PrettyTCM a, Agda.TypeChecking.Substitute.Class.EndoSubst a) => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Substitution' a)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.Arg Agda.Syntax.Abstract.Expr)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.Arg Agda.Syntax.Internal.Term)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.Arg Agda.Syntax.Internal.Type)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.Arg GHC.Types.Bool)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.NamedArg Agda.Syntax.Abstract.Expr)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.NamedArg Agda.Syntax.Internal.Term)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Common.Named_ Agda.Syntax.Internal.Term)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Dom (Agda.Syntax.Abstract.Name.Name, Agda.Syntax.Internal.Type))

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Dom Agda.Syntax.Internal.Type)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.DisplayTerm)

+ 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.Common.ProblemId

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Internal.Blockers.Blocker

+ 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.Candidate

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM GHC.Base.String

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM a => Agda.TypeChecking.Pretty.PrettyTCM (GHC.Maybe.Maybe a)

+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCMWithNode Agda.TypeChecking.Positivity.Occurrence.Occurrence

+ Agda.TypeChecking.Pretty: instance GHC.Base.Semigroup (Agda.TypeChecking.Monad.Base.TCM Agda.TypeChecking.Pretty.Doc)

+ Agda.TypeChecking.Pretty: parensNonEmpty :: Functor m => m Doc -> m Doc

+ Agda.TypeChecking.Pretty: prettyTCMWithNode :: (PrettyTCMWithNode a, PrettyTCM n, MonadPretty m) => WithNode n a -> m Doc

+ Agda.TypeChecking.Pretty: quotes :: Functor m => m Doc -> m Doc

+ Agda.TypeChecking.Pretty: type MonadAbsToCon m = (MonadTCEnv m, ReadTCState m, MonadStConcreteNames m, HasOptions m, HasBuiltins m, MonadDebug m)

+ Agda.TypeChecking.Pretty.Constraint: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.Constraint

+ Agda.TypeChecking.Pretty.Constraint: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.ProblemConstraint

+ Agda.TypeChecking.Pretty.Constraint: interestingConstraint :: ProblemConstraint -> Bool

+ Agda.TypeChecking.Pretty.Constraint: prettyConstraint :: MonadPretty m => ProblemConstraint -> m Doc

+ Agda.TypeChecking.Pretty.Constraint: prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]

+ Agda.TypeChecking.Pretty.Warning: applyFlagsToTCWarningsPreserving :: HasOptions m => Set WarningName -> [TCWarning] -> m [TCWarning]

+ Agda.TypeChecking.Pretty.Warning: didYouMean :: (MonadPretty m, Pretty a, Pretty b) => [QName] -> (a -> b) -> a -> Maybe (m Doc)

+ Agda.TypeChecking.Pretty.Warning: getAllUnsolvedWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => m [TCWarning]

+ Agda.TypeChecking.Pretty.Warning: getAllWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => WhichWarnings -> m [TCWarning]

+ Agda.TypeChecking.Pretty.Warning: getAllWarningsOfTCErr :: TCErr -> TCM [TCWarning]

+ Agda.TypeChecking.Pretty.Warning: getAllWarningsPreserving :: (MonadFail m, ReadTCState m, MonadWarning m) => Set WarningName -> WhichWarnings -> m [TCWarning]

+ Agda.TypeChecking.Pretty.Warning: prettyDuplicateFields :: MonadPretty m => [Name] -> m Doc

+ Agda.TypeChecking.Pretty.Warning: prettyNotInScopeNames :: (MonadPretty m, Pretty a, HasRange a) => Bool -> (a -> m Doc) -> [a] -> m Doc

+ Agda.TypeChecking.Pretty.Warning: prettyRecordFieldWarning :: MonadPretty m => RecordFieldWarning -> m Doc

+ Agda.TypeChecking.Pretty.Warning: prettyTooManyFields :: MonadPretty m => QName -> [Name] -> [Name] -> m Doc

+ Agda.TypeChecking.Primitive: instance (Agda.TypeChecking.Primitive.PrimType a, Agda.TypeChecking.Primitive.PrimType b) => Agda.TypeChecking.Primitive.PrimType (a -> b)

+ Agda.TypeChecking.Primitive: instance (Agda.TypeChecking.Primitive.PrimType a, Agda.TypeChecking.Primitive.PrimType b) => Agda.TypeChecking.Primitive.PrimType (a, b)

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.FromTerm Data.Text.Internal.Text

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.FromTerm a => Agda.TypeChecking.Primitive.FromTerm (GHC.Maybe.Maybe a)

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm Data.Text.Internal.Text

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm a => Agda.TypeChecking.Primitive.PrimTerm (GHC.Maybe.Maybe a)

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm a => Agda.TypeChecking.Primitive.PrimType (GHC.Maybe.Maybe a)

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm a => Agda.TypeChecking.Primitive.PrimType (GHC.Types.IO a)

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm a => Agda.TypeChecking.Primitive.PrimType [a]

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Agda.Syntax.Abstract.Name.QName

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Agda.Syntax.Common.Fixity'

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Agda.Syntax.Common.MetaId

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Agda.Syntax.Internal.Type

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Agda.TypeChecking.Primitive.Lvl

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Agda.TypeChecking.Primitive.Nat

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType Data.Text.Internal.Text

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Integer.Type.Integer

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Types.Bool

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Types.Char

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Types.Double

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Word.Word64

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.ToTerm Data.Text.Internal.Text

+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.ToTerm a => Agda.TypeChecking.Primitive.ToTerm (GHC.Maybe.Maybe a)

+ Agda.TypeChecking.Primitive: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Primitive.Lvl

+ Agda.TypeChecking.Primitive: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Primitive.Nat

+ Agda.TypeChecking.Primitive: mkPrimFun3 :: (PrimType a, FromTerm a, ToTerm a, PrimType b, FromTerm b, ToTerm b, PrimType c, FromTerm c, PrimType d, ToTerm d) => (a -> b -> c -> d) -> TCM PrimitiveImpl

+ Agda.TypeChecking.Primitive: primLockUniv' :: TCM PrimitiveImpl

+ Agda.TypeChecking.Primitive: primStringFromListInjective :: TCM PrimitiveImpl

+ Agda.TypeChecking.Primitive.Base: el's :: Applicative m => m Term -> m Term -> m Type

+ Agda.TypeChecking.Primitive.Base: elSSet :: Functor m => m Term -> m Type

+ Agda.TypeChecking.Primitive.Base: tMaybe :: TCM Term -> TCM Term

+ Agda.TypeChecking.Primitive.Cubical: primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type

+ 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.Quote: quotedName :: (MonadTCError m, MonadAbsToCon m) => Expr -> m QName

+ Agda.TypeChecking.ReconstructParameters: reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term

+ Agda.TypeChecking.ReconstructParameters: reconstructParametersInType' :: Action TCM -> Type -> TCM Type

+ Agda.TypeChecking.RecordPatterns: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.TypeChecking.RecordPatterns.RecPatM

+ Agda.TypeChecking.Records: failOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a

+ Agda.TypeChecking.Records: insertMissingFieldsFail :: forall a. HasRange a => QName -> (Name -> a) -> [FieldAssignment' a] -> [Arg Name] -> TCM [NamedArg a]

+ Agda.TypeChecking.Records: insertMissingFieldsWarn :: forall a. HasRange a => QName -> (Name -> a) -> [FieldAssignment' a] -> [Arg Name] -> TCM [NamedArg a]

+ Agda.TypeChecking.Records: orderFieldsFail :: forall a. HasRange a => QName -> (Arg Name -> a) -> [Arg Name] -> [(Name, a)] -> TCM [a]

+ Agda.TypeChecking.Records: orderFieldsWarn :: forall a. HasRange a => QName -> (Arg Name -> a) -> [Arg Name] -> [(Name, a)] -> TCM [a]

+ Agda.TypeChecking.Records: warnOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a

+ Agda.TypeChecking.Reduce: abortIfBlocked :: (MonadReduce m, MonadBlock m, IsMeta t, Reduce t) => t -> m t

+ Agda.TypeChecking.Reduce: blockAll :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)

+ Agda.TypeChecking.Reduce: blockAny :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.InstantiateFull a) => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.InstantiateFull a) => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.Normalise a) => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.Normalise a) => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.Reduce a) => Agda.TypeChecking.Reduce.Reduce (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.Simplify a) => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Reduce: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Reduce.Simplify a) => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate Agda.Syntax.Internal.Blockers.Blocker

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate t => Agda.TypeChecking.Reduce.Instantiate (Agda.Syntax.Internal.Elim.Elim' t)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate t => Agda.TypeChecking.Reduce.Instantiate (Agda.Syntax.Internal.PlusLevel' t)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Instantiate t => Agda.TypeChecking.Reduce.Instantiate (Agda.TypeChecking.Monad.Base.IPBoundary' t)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull t => Agda.TypeChecking.Reduce.InstantiateFull (Agda.Syntax.Internal.Elim.Elim' t)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull t => Agda.TypeChecking.Reduce.InstantiateFull (Agda.TypeChecking.Monad.Base.IPBoundary' t)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Common.Arg a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.Level' a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.PlusLevel' a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.Sort' a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.IsMeta a => Agda.TypeChecking.Reduce.IsMeta (Agda.Syntax.Internal.Type'' t a)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Normalise t => Agda.TypeChecking.Reduce.Normalise (Agda.Syntax.Internal.Elim.Elim' t)

+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Simplify t => Agda.TypeChecking.Reduce.Simplify (Agda.Syntax.Internal.Elim.Elim' t)

+ Agda.TypeChecking.Reduce: reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)

+ Agda.TypeChecking.Reduce: reduceWithBlocker :: (Reduce a, IsMeta a, MonadReduce m) => a -> m (Blocker, a)

+ Agda.TypeChecking.Reduce: withReduced :: (Reduce a, IsMeta a, MonadReduce m, MonadBlock m) => a -> (a -> m b) -> m b

+ Agda.TypeChecking.Reduce.Monad: instance Agda.TypeChecking.Monad.Pure.PureTCM Agda.TypeChecking.Monad.Base.ReduceM

+ 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.Clause: instance Agda.TypeChecking.Rewriting.Clause.ToNLPat a b => Agda.TypeChecking.Rewriting.Clause.ToNLPat (Agda.Syntax.Internal.Elim.Elim' a) (Agda.Syntax.Internal.Elim.Elim' b)

+ Agda.TypeChecking.Rewriting.Confluence: checkConfluenceOfClauses :: ConfluenceCheck -> QName -> TCM ()

+ 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.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.MetasToVars a => Agda.TypeChecking.Rewriting.Confluence.MetasToVars (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce Agda.Syntax.Internal.Sort

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce Agda.Syntax.Internal.Term

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce (Agda.Syntax.Common.Arg a)

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce (Agda.Syntax.Internal.Dom a)

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce (Agda.Syntax.Internal.Type' a)

+ Agda.TypeChecking.Rewriting.Confluence: instance Agda.TypeChecking.Rewriting.Confluence.ParallelReduce a => Agda.TypeChecking.Rewriting.Confluence.ParallelReduce [a]

+ Agda.TypeChecking.Rewriting.Confluence: sortRulesOfSymbol :: QName -> TCM ()

+ Agda.TypeChecking.Rewriting.NonLinMatch: NLM :: ExceptT Blocked_ (StateT NLMState ReduceM) a -> NLM a

+ Agda.TypeChecking.Rewriting.NonLinMatch: [unNLM] :: NLM a -> ExceptT Blocked_ (StateT NLMState ReduceM) a

+ Agda.TypeChecking.Rewriting.NonLinMatch: getTypedHead :: PureTCM m => Term -> m (Maybe (QName, Type))

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.Interaction.Options.HasOptions.HasOptions Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Base.MonadBlock Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Base.MonadReduce Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Base.MonadTCEnv Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Base.ReadTCState Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Builtin.HasBuiltins Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Context.MonadAddContext Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Debug.MonadDebug Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Pure.PureTCM Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Monad.Signature.HasConstInfo Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Agda.TypeChecking.Rewriting.NonLinMatch.Match (Agda.Syntax.Internal.Type, Agda.Syntax.Internal.Elims -> Agda.Syntax.Internal.Term) [Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat] Agda.Syntax.Internal.Elims

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Control.Monad.Error.Class.MonadError Agda.Syntax.Internal.Blocked_ Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Control.Monad.Fail.MonadFail Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance Control.Monad.State.Class.MonadState Agda.TypeChecking.Rewriting.NonLinMatch.NLMState Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance GHC.Base.Alternative Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance GHC.Base.Applicative Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance GHC.Base.Functor Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance GHC.Base.Monad Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: instance GHC.Base.MonadPlus Agda.TypeChecking.Rewriting.NonLinMatch.NLM

+ Agda.TypeChecking.Rewriting.NonLinMatch: newtype NLM a

+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables a => Agda.TypeChecking.Rewriting.NonLinPattern.GetMatchables (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm p a => Agda.TypeChecking.Rewriting.NonLinPattern.NLPatToTerm (Agda.Syntax.Internal.Elim.Elim' p) (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Rewriting.NonLinPattern: instance Agda.TypeChecking.Rewriting.NonLinPattern.PatternFrom (Agda.Syntax.Internal.Type, Agda.Syntax.Internal.Term) Agda.Syntax.Internal.Elims [Agda.Syntax.Internal.Elim.Elim' Agda.TypeChecking.Monad.Base.NLPat]

+ Agda.TypeChecking.Rules.Data: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.Data.CType

+ Agda.TypeChecking.Rules.Data: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.Data.LType

+ Agda.TypeChecking.Rules.Def: [wfCallSubst] :: WithFunctionProblem -> Substitution

+ Agda.TypeChecking.Rules.Def: getReflPattern :: TCM Pattern

+ Agda.TypeChecking.Rules.Def: insertInspects :: [Arg (Maybe BindName)] -> LHSCore -> LHSCore

+ Agda.TypeChecking.Rules.Def: insertNames :: [Arg (Maybe BindName)] -> RHS -> RHS

+ Agda.TypeChecking.Rules.Def: mapLHSCores :: (LHSCore -> LHSCore) -> RHS -> RHS

+ Agda.TypeChecking.Rules.LHS: IsData :: DataOrRecord

+ Agda.TypeChecking.Rules.LHS: IsRecord :: Maybe Induction -> EtaEquality -> DataOrRecord

+ Agda.TypeChecking.Rules.LHS: [recordEtaEquality] :: DataOrRecord -> EtaEquality

+ Agda.TypeChecking.Rules.LHS: [recordInduction] :: DataOrRecord -> Maybe Induction

+ Agda.TypeChecking.Rules.LHS: data DataOrRecord

+ Agda.TypeChecking.Rules.LHS: instance GHC.Show.Show Agda.TypeChecking.Rules.LHS.DataOrRecord

+ Agda.TypeChecking.Rules.LHS.Problem: Ann :: Expr -> Type -> AnnotationPattern

+ Agda.TypeChecking.Rules.LHS.Problem: [typeAnnotations] :: LeftoverPatterns -> [AnnotationPattern]

+ Agda.TypeChecking.Rules.LHS.Problem: data AnnotationPattern

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Problem.AnnotationPattern

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst (Agda.TypeChecking.Rules.LHS.Problem.Problem a)

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.LHS.Problem.AbsurdPattern

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.LHS.Problem.AsBinding

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.LHS.Problem.DotPattern

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.Utils.Null.Null Agda.TypeChecking.Rules.LHS.Problem.LeftoverPatterns

+ Agda.TypeChecking.Rules.LHS.Problem: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Rules.LHS.Problem.PatVarPosition

+ Agda.TypeChecking.Rules.LHS.Unify: UnifyBlocked :: Blocker -> UnificationResult' a

+ Agda.TypeChecking.Rules.LHS.Unify: UnifyStuck :: [UnificationFailure] -> UnificationResult' a

+ Agda.TypeChecking.Rules.Term: checkDomain :: (LensLock a, LensModality a) => LamOrPi -> List1 a -> Expr -> TCM Type

+ Agda.TypeChecking.Rules.Term: checkLambda' :: Comparison -> TypedBinding -> List1 (NamedArg Binder) -> Expr -> Expr -> Type -> TCM Term

+ Agda.TypeChecking.Rules.Term: checkPiDomain :: (LensLock a, LensModality a) => List1 a -> Expr -> TCM Type

+ Agda.TypeChecking.Rules.Term: checkPostponedLambda0 :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> Expr -> Type -> TCM Term

+ Agda.TypeChecking.Rules.Term: lambdaAnnotationCheck :: LensAnnotation dom => dom -> ArgInfo -> TCM ArgInfo

+ Agda.TypeChecking.Serialise.Base: [lTextC] :: Dict -> !IORef FreshAndReuse

+ Agda.TypeChecking.Serialise.Base: [lTextD] :: Dict -> !HashTable Text Int32

+ Agda.TypeChecking.Serialise.Base: [lTextE] :: St -> !Array Int32 Text

+ Agda.TypeChecking.Serialise.Base: [sTextC] :: Dict -> !IORef FreshAndReuse

+ Agda.TypeChecking.Serialise.Base: [sTextD] :: Dict -> !HashTable Text Int32

+ Agda.TypeChecking.Serialise.Base: [sTextE] :: St -> !Array Int32 Text

+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Abstract.Name.Suffix

+ Agda.TypeChecking.Serialise.Instances.Abstract: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Scope.Base.DataOrRecordModule

+ 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 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 Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.Annotation

+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.Lock

+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.ModuleNameHash

+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.PatternOrCopattern

+ 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.Stack.Types.CallStack

+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Stack.Types.SrcLoc

+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Syntax.Common.HasEta' 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.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Base.ExecutablesFile

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Base.LibPositionInfo

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Base.LibWarning

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Library.Base.LibWarning'

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.Base.ConfluenceCheck

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.Base.PragmaOptions

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Concrete.Glyph.UnicodeOrAscii

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Parser.Monad.ParseWarning

+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.RecordFieldWarning

+ Agda.TypeChecking.Serialise.Instances.Highlighting: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.RangeMap.PairInt a)

+ Agda.TypeChecking.Serialise.Instances.Highlighting: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.RangeMap.RangeMap a)

+ 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.Syntax.Internal.IsFibrant

+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.SizedTypes: isBoundedProjVar :: (MonadCheckInternal m, PureTCM m) => ProjectedVar -> m BoundedSize

+ Agda.TypeChecking.SizedTypes: isBoundedSizeType :: PureTCM m => Type -> m BoundedSize

+ Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.SizedTypes.Syntax.Flexs Agda.TypeChecking.SizedTypes.Solve.HypSizeConstraint

+ Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.Substitute.Class.Subst (Agda.TypeChecking.SizedTypes.Syntax.SizeExpr' Agda.TypeChecking.SizedTypes.Solve.NamedRigid Agda.TypeChecking.SizedTypes.Solve.SizeMeta)

+ Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.SizedTypes.Solve.SizeConstraint

+ Agda.TypeChecking.SizedTypes.Solve: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.SizedTypes.Solve.SizeMeta

+ Agda.TypeChecking.SizedTypes.Syntax: instance Agda.TypeChecking.SizedTypes.Syntax.Flexs a => Agda.TypeChecking.SizedTypes.Syntax.Flexs [a]

+ Agda.TypeChecking.SizedTypes.Syntax: instance Agda.TypeChecking.SizedTypes.Syntax.Rigids a => Agda.TypeChecking.SizedTypes.Syntax.Rigids [a]

+ Agda.TypeChecking.SizedTypes.Syntax: instance GHC.Classes.Ord flex => Agda.TypeChecking.SizedTypes.Syntax.Flexs (Agda.TypeChecking.SizedTypes.Syntax.Constraint' rigid flex)

+ Agda.TypeChecking.SizedTypes.Syntax: instance GHC.Classes.Ord flex => Agda.TypeChecking.SizedTypes.Syntax.Flexs (Agda.TypeChecking.SizedTypes.Syntax.SizeExpr' rigid flex)

+ Agda.TypeChecking.SizedTypes.Syntax: instance GHC.Classes.Ord r => Agda.TypeChecking.SizedTypes.Syntax.Rigids (Agda.TypeChecking.SizedTypes.Syntax.Constraint' r f)

+ Agda.TypeChecking.SizedTypes.Syntax: instance GHC.Classes.Ord r => Agda.TypeChecking.SizedTypes.Syntax.Rigids (Agda.TypeChecking.SizedTypes.Syntax.SizeExpr' r f)

+ Agda.TypeChecking.SizedTypes.Syntax: type family FlexOf a;

+ Agda.TypeChecking.SizedTypes.Syntax: }

+ Agda.TypeChecking.Sort: ifNotSort :: (MonadReduce m, MonadBlock m) => Type -> m a -> (Sort -> m a) -> m a

+ Agda.TypeChecking.Sort: sortOfType :: forall m. (PureTCM m, MonadBlock m) => Type -> m Sort

+ Agda.TypeChecking.Substitute: bindsToTel'1 :: (Name -> a) -> List1 Name -> Dom Type -> ListTel' a

+ Agda.TypeChecking.Substitute: bindsToTel1 :: List1 Name -> Dom Type -> ListTel

+ Agda.TypeChecking.Substitute: fibrantLub :: IsFibrant -> IsFibrant -> IsFibrant

+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Substitute.Class.Subst b, Agda.TypeChecking.Substitute.Class.Subst c, Agda.TypeChecking.Substitute.Class.Subst d, Agda.TypeChecking.Substitute.Class.SubstArg a GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg b, Agda.TypeChecking.Substitute.Class.SubstArg b GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg c, Agda.TypeChecking.Substitute.Class.SubstArg c GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg d) => Agda.TypeChecking.Substitute.Class.Subst (a, b, c, d)

+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.Substitute.Class.Subst b, Agda.TypeChecking.Substitute.Class.Subst c, Agda.TypeChecking.Substitute.Class.SubstArg a GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg b, Agda.TypeChecking.Substitute.Class.SubstArg b GHC.Types.~ Agda.TypeChecking.Substitute.Class.SubstArg c) => Agda.TypeChecking.Substitute.Class.Subst (a, b, c)

+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.Syntax.Internal.Abs a)

+ 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.Eq a) => GHC.Classes.Eq (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.Subst a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.Syntax.Internal.Abs 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 (Agda.TypeChecking.Substitute.Class.Subst a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.TermSubst a, GHC.Classes.Eq a) => GHC.Classes.Eq (Agda.TypeChecking.Substitute.TelV a)

+ Agda.TypeChecking.Substitute: instance (Agda.TypeChecking.Substitute.Class.TermSubst a, GHC.Classes.Ord a) => GHC.Classes.Ord (Agda.TypeChecking.Substitute.TelV a)

+ Agda.TypeChecking.Substitute: instance (GHC.Classes.Ord k, Agda.TypeChecking.Substitute.Class.Subst a) => Agda.TypeChecking.Substitute.Class.Subst (Data.Map.Internal.Map k 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.EndoSubst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Substitution' a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst ()

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Abstract.Name.Name

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Abstract.ProblemEq

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.BraveTerm

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.ConPatternInfo

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.DeBruijnPattern

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.EqualityView

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Pattern

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.Term

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Position.Range

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.Candidate

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.CompareAs

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.Constraint

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.DisplayForm

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Monad.Base.DisplayTerm

+ 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.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Common.Arg a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Common.Named name a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Common.WithHiding a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Blocked a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Level' a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.PlusLevel' a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (GHC.Maybe.Maybe a)

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst [a]

+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.TermSubst a => Agda.TypeChecking.Substitute.Class.Apply (Agda.Syntax.Internal.Tele a)

+ Agda.TypeChecking.Substitute: instance GHC.Classes.Eq Agda.TypeChecking.Monad.Base.CandidateKind

+ Agda.TypeChecking.Substitute: isSmallSort :: Sort -> Maybe (Bool, IsFibrant)

+ Agda.TypeChecking.Substitute: lamView :: Term -> ([Arg ArgName], Term)

+ Agda.TypeChecking.Substitute: mkPiSort :: Dom Type -> Abs Type -> Sort

+ Agda.TypeChecking.Substitute: namedBindsToTel1 :: List1 (NamedArg Name) -> Type -> Telescope

+ Agda.TypeChecking.Substitute: sort :: Sort -> Type

+ Agda.TypeChecking.Substitute: ssort :: Level -> Type

+ Agda.TypeChecking.Substitute: unlamView :: [Arg ArgName] -> Term -> Term

+ Agda.TypeChecking.Substitute.Class: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Abstract.Name.QName

+ Agda.TypeChecking.Substitute.Class: raiseFromS :: Nat -> Nat -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: type EndoSubst a = SubstWith a a

+ Agda.TypeChecking.Substitute.Class: type SubstWith t a = (Subst a, SubstArg a ~ t)

+ Agda.TypeChecking.Substitute.Class: type TermSubst a = SubstWith Term a

+ Agda.TypeChecking.Substitute.Class: type family SubstArg a;

+ Agda.TypeChecking.Substitute.Class: }

+ Agda.TypeChecking.SyntacticEquality: instance (Agda.TypeChecking.Substitute.Class.Subst a, Agda.TypeChecking.SyntacticEquality.SynEq a) => Agda.TypeChecking.SyntacticEquality.SynEq (Agda.Syntax.Internal.Abs a)

+ Agda.TypeChecking.SyntacticEquality: instance (Agda.TypeChecking.SyntacticEquality.SynEq a, Agda.TypeChecking.SyntacticEquality.SynEq b) => Agda.TypeChecking.SyntacticEquality.SynEq (a, b)

+ Agda.TypeChecking.SyntacticEquality: instance Agda.TypeChecking.SyntacticEquality.SynEq a => Agda.TypeChecking.SyntacticEquality.SynEq (Agda.Syntax.Internal.Elim.Elim' a)

+ Agda.TypeChecking.Telescope: piApplyM' :: (PiApplyM a, MonadReduce m, HasBuiltins m) => m Empty -> Type -> a -> m Type

+ Agda.TypeChecking.Telescope.Path: arityPiPath :: Type -> TCM Int

+ Agda.TypeChecking.Telescope.Path: isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool

+ Agda.TypeChecking.Telescope.Path: telePiPath_ :: Telescope -> Type -> [(Int, (Term, Term))] -> TCM Type

+ Agda.TypeChecking.Unquote: exitCodeToNat :: ExitCode -> Nat

+ Agda.TypeChecking.Unquote: instance (Agda.TypeChecking.Unquote.Unquote a, Agda.TypeChecking.Unquote.Unquote b) => Agda.TypeChecking.Unquote.Unquote (a, b)

+ Agda.TypeChecking.Unquote: instance Agda.TypeChecking.Unquote.Unquote Agda.Syntax.Common.Quantity

+ Agda.TypeChecking.Unquote: instance Agda.TypeChecking.Unquote.Unquote Data.Text.Internal.Text

+ Agda.TypeChecking.Unquote: prettyErrorParts :: [ErrorPart] -> TCM Doc

+ Agda.TypeChecking.Unquote: raiseExeNotFound :: ExeName -> Map ExeName FilePath -> TCM a

+ Agda.TypeChecking.Unquote: requireAllowExec :: TCM ()

+ Agda.TypeChecking.Unquote: tcExec :: ExeName -> [ExeArg] -> StdIn -> TCM Term

+ Agda.TypeChecking.Unquote: type ExeArg = Text

+ Agda.TypeChecking.Unquote: type StdErr = Text

+ Agda.TypeChecking.Unquote: type StdIn = Text

+ Agda.TypeChecking.Unquote: type StdOut = Text

+ Agda.TypeChecking.Warnings: raiseWarningsOnUsage :: (MonadWarning m, ReadTCState m) => QName -> m ()

+ Agda.TypeChecking.Warnings: warning' :: MonadWarning m => CallStack -> Warning -> m ()

+ Agda.TypeChecking.Warnings: warning'_ :: MonadWarning m => CallStack -> Warning -> m TCWarning

+ Agda.Utils.Applicative: foldA :: (Alternative f, Foldable t) => t a -> f a

+ Agda.Utils.Applicative: foldMapA :: (Alternative f, Foldable t) => (a -> f b) -> t a -> f b

+ Agda.Utils.Applicative: forA :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)

+ Agda.Utils.Benchmark: instance (Agda.Utils.Benchmark.MonadBench m, GHC.Base.Monoid w) => Agda.Utils.Benchmark.MonadBench (Control.Monad.Trans.Writer.Lazy.WriterT w m)

+ Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench m => Agda.Utils.Benchmark.MonadBench (Agda.Utils.ListT.ListT m)

+ Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench m => Agda.Utils.Benchmark.MonadBench (Control.Monad.Trans.Except.ExceptT e m)

+ Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench m => Agda.Utils.Benchmark.MonadBench (Control.Monad.Trans.Reader.ReaderT r m)

+ Agda.Utils.Benchmark: instance Agda.Utils.Benchmark.MonadBench m => Agda.Utils.Benchmark.MonadBench (Control.Monad.Trans.State.Lazy.StateT r m)

+ Agda.Utils.Benchmark: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.Benchmark.Benchmark a)

+ Agda.Utils.Benchmark: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.Benchmark.BenchmarkOn a)

+ Agda.Utils.Benchmark: instance GHC.Generics.Generic (Agda.Utils.Benchmark.Benchmark a)

+ Agda.Utils.Benchmark: instance GHC.Generics.Generic (Agda.Utils.Benchmark.BenchmarkOn a)

+ Agda.Utils.Benchmark: type family BenchPhase m;

+ Agda.Utils.Benchmark: }

+ Agda.Utils.BiMap: adjust :: (Ord k, Ord (Tag v), HasTag v) => (v -> v) -> k -> BiMap k v -> BiMap k v

+ Agda.Utils.BiMap: adjustPrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => (v -> v) -> k -> BiMap k v -> Bool

+ Agda.Utils.BiMap: alter :: forall k v. (Ord k, Ord (Tag v), HasTag v) => (Maybe v -> Maybe v) -> k -> BiMap k v -> BiMap k v

+ Agda.Utils.BiMap: alterM :: forall k v m. (Ord k, Ord (Tag v), HasTag v, Monad m) => (Maybe v -> m (Maybe v)) -> k -> BiMap k v -> m (BiMap k v)

+ 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: biMapInvariant :: (Eq k, Eq v, Ord (Tag v), HasTag v) => BiMap k v -> Bool

+ Agda.Utils.BiMap: class HasTag a where {

+ Agda.Utils.BiMap: elems :: BiMap k v -> [v]

+ Agda.Utils.BiMap: fromDistinctAscendingLists :: ([(k, v)], [(Tag v, k)]) -> BiMap k v

+ Agda.Utils.BiMap: fromDistinctAscendingListsPrecondition :: (Ord k, Eq v, Ord (Tag v), HasTag v) => ([(k, v)], [(Tag v, k)]) -> Bool

+ Agda.Utils.BiMap: fromListPrecondition :: (Eq k, Eq v, Eq (Tag v), HasTag v) => [(k, v)] -> Bool

+ Agda.Utils.BiMap: insertLookupWithKey :: forall k v. (Ord k, Ord (Tag v), HasTag v) => (k -> v -> v -> v) -> k -> v -> BiMap k v -> (Maybe v, BiMap k v)

+ 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: insertPrecondition :: (Eq k, Eq v, Eq (Tag v), HasTag v) => k -> v -> BiMap k v -> Bool

+ Agda.Utils.BiMap: instance (GHC.Classes.Eq k, GHC.Classes.Eq v) => GHC.Classes.Eq (Agda.Utils.BiMap.BiMap k v)

+ Agda.Utils.BiMap: instance (GHC.Classes.Ord k, GHC.Classes.Ord v) => GHC.Classes.Ord (Agda.Utils.BiMap.BiMap k v)

+ Agda.Utils.BiMap: instance (GHC.Show.Show k, GHC.Show.Show v) => GHC.Show.Show (Agda.Utils.BiMap.BiMap k v)

+ Agda.Utils.BiMap: instance Agda.Utils.Null.Null (Agda.Utils.BiMap.BiMap k v)

+ Agda.Utils.BiMap: instance GHC.Generics.Generic (Agda.Utils.BiMap.BiMap k v)

+ Agda.Utils.BiMap: keys :: BiMap k v -> [k]

+ Agda.Utils.BiMap: mapWithKey :: (Ord k, Ord (Tag v), HasTag v) => (k -> v -> v) -> BiMap k v -> BiMap k v

+ Agda.Utils.BiMap: mapWithKeyFixedTags :: (k -> v -> v) -> BiMap k v -> BiMap k v

+ Agda.Utils.BiMap: mapWithKeyFixedTagsPrecondition :: (Eq v, Eq (Tag v), HasTag v) => (k -> v -> v) -> BiMap k v -> Bool

+ Agda.Utils.BiMap: mapWithKeyPrecondition :: (Eq k, Eq v, Eq (Tag v), HasTag v) => (k -> v -> v) -> BiMap k v -> Bool

+ Agda.Utils.BiMap: tag :: HasTag a => a -> Maybe (Tag a)

+ Agda.Utils.BiMap: tagInjectiveFor :: (Eq v, Eq (Tag v), HasTag v) => [v] -> Bool

+ Agda.Utils.BiMap: toDistinctAscendingLists :: BiMap k v -> ([(k, v)], [(Tag v, k)])

+ Agda.Utils.BiMap: type family Tag a;

+ Agda.Utils.BiMap: unionPrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => BiMap k v -> BiMap k v -> Bool

+ Agda.Utils.BiMap: update :: (Ord k, Ord (Tag v), HasTag v) => (v -> Maybe v) -> k -> BiMap k v -> BiMap k v

+ Agda.Utils.BiMap: updatePrecondition :: (Ord k, Eq v, Eq (Tag v), HasTag v) => (v -> Maybe v) -> k -> BiMap k v -> Bool

+ Agda.Utils.BiMap: }

+ Agda.Utils.CallStack: SrcLoc :: [Char] -> [Char] -> [Char] -> Int -> Int -> Int -> Int -> SrcLoc

+ Agda.Utils.CallStack: [srcLocEndCol] :: SrcLoc -> Int

+ Agda.Utils.CallStack: [srcLocEndLine] :: SrcLoc -> Int

+ Agda.Utils.CallStack: [srcLocFile] :: SrcLoc -> [Char]

+ Agda.Utils.CallStack: [srcLocModule] :: SrcLoc -> [Char]

+ Agda.Utils.CallStack: [srcLocPackage] :: SrcLoc -> [Char]

+ Agda.Utils.CallStack: [srcLocStartCol] :: SrcLoc -> Int

+ Agda.Utils.CallStack: [srcLocStartLine] :: SrcLoc -> Int

+ Agda.Utils.CallStack: callStack :: HasCallStack => CallStack

+ Agda.Utils.CallStack: data CallStack

+ Agda.Utils.CallStack: data SrcLoc

+ Agda.Utils.CallStack: filterCallStack :: CallSiteFilter -> CallStack -> CallStack

+ Agda.Utils.CallStack: fromCallSiteList :: [([Char], SrcLoc)] -> CallStack

+ Agda.Utils.CallStack: getCallStack :: CallStack -> [([Char], SrcLoc)]

+ Agda.Utils.CallStack: headCallSite :: CallStack -> Maybe CallSite

+ Agda.Utils.CallStack: overCallSites :: ([CallSite] -> [CallSite]) -> CallStack -> CallStack

+ Agda.Utils.CallStack: popnCallStack :: Word -> CallStack -> CallStack

+ Agda.Utils.CallStack: prettyCallSite :: CallSite -> String

+ Agda.Utils.CallStack: prettyCallStack :: CallStack -> String

+ Agda.Utils.CallStack: prettySrcLoc :: SrcLoc -> String

+ Agda.Utils.CallStack: truncatedCallStack :: CallStack -> CallStack

+ Agda.Utils.CallStack: type CallSite = (SrcFun, SrcLoc)

+ Agda.Utils.CallStack: type CallSiteFilter = CallSite -> Bool

+ Agda.Utils.CallStack: type HasCallStack = ?callStack :: CallStack

+ Agda.Utils.CallStack: type SrcFun = String

+ Agda.Utils.CallStack: type SrcLocCol = Int

+ Agda.Utils.CallStack: type SrcLocFile = String

+ Agda.Utils.CallStack: type SrcLocLine = Int

+ Agda.Utils.CallStack: type SrcLocModule = String

+ Agda.Utils.CallStack: type SrcLocPackage = String

+ Agda.Utils.CallStack: withCallerCallStack :: HasCallStack => (CallStack -> b) -> b

+ Agda.Utils.CallStack: withCurrentCallStack :: HasCallStack => (CallStack -> b) -> b

+ Agda.Utils.CallStack: withNBackCallStack :: HasCallStack => Word -> (CallStack -> b) -> b

+ Agda.Utils.Char: integerToChar :: Integer -> Char

+ Agda.Utils.Char: isSurrogateCodePoint :: Char -> Bool

+ Agda.Utils.Char: replaceSurrogateCodePoint :: Char -> Char

+ Agda.Utils.Char: replacementChar :: Char

+ Agda.Utils.Either: swapEither :: Either a b -> Either b a

+ Agda.Utils.Empty: instance Control.DeepSeq.NFData Agda.Utils.Empty.Empty

+ Agda.Utils.FileName: canonicalizeAbsolutePath :: AbsolutePath -> IO AbsolutePath

+ Agda.Utils.FileName: instance Control.DeepSeq.NFData Agda.Utils.FileName.AbsolutePath

+ Agda.Utils.FileName: isNewerThan :: FilePath -> FilePath -> IO Bool

+ Agda.Utils.FileName: sameFile :: AbsolutePath -> AbsolutePath -> IO Bool

+ Agda.Utils.Float: asFinite :: Double -> Maybe Double

+ Agda.Utils.Float: doubleACos :: Double -> Double

+ Agda.Utils.Float: doubleACosh :: Double -> Double

+ Agda.Utils.Float: doubleASin :: Double -> Double

+ Agda.Utils.Float: doubleASinh :: Double -> Double

+ Agda.Utils.Float: doubleATan :: Double -> Double

+ Agda.Utils.Float: doubleATan2 :: Double -> Double -> Double

+ Agda.Utils.Float: doubleATanh :: Double -> Double

+ Agda.Utils.Float: doubleCeiling :: Double -> Maybe Integer

+ Agda.Utils.Float: doubleCos :: Double -> Double

+ Agda.Utils.Float: doubleCosh :: Double -> Double

+ Agda.Utils.Float: doubleDecode :: Double -> Maybe (Integer, Integer)

+ Agda.Utils.Float: doubleDenotEq :: Double -> Double -> Bool

+ Agda.Utils.Float: doubleDenotOrd :: Double -> Double -> Ordering

+ Agda.Utils.Float: doubleDiv :: Double -> Double -> Double

+ Agda.Utils.Float: doubleEncode :: Integer -> Integer -> Maybe Double

+ Agda.Utils.Float: doubleEq :: Double -> Double -> Bool

+ Agda.Utils.Float: doubleExp :: Double -> Double

+ Agda.Utils.Float: doubleFloor :: Double -> Maybe Integer

+ Agda.Utils.Float: doubleLe :: Double -> Double -> Bool

+ Agda.Utils.Float: doubleLog :: Double -> Double

+ Agda.Utils.Float: doubleLt :: Double -> Double -> Bool

+ Agda.Utils.Float: doubleMinus :: Double -> Double -> Double

+ Agda.Utils.Float: doubleNegate :: Double -> Double

+ Agda.Utils.Float: doublePlus :: Double -> Double -> Double

+ Agda.Utils.Float: doublePow :: Double -> Double -> Double

+ Agda.Utils.Float: doubleRound :: Double -> Maybe Integer

+ Agda.Utils.Float: doubleSin :: Double -> Double

+ Agda.Utils.Float: doubleSinh :: Double -> Double

+ Agda.Utils.Float: doubleSqrt :: Double -> Double

+ Agda.Utils.Float: doubleTan :: Double -> Double

+ Agda.Utils.Float: doubleTanh :: Double -> Double

+ Agda.Utils.Float: doubleTimes :: Double -> Double -> Double

+ Agda.Utils.Float: doubleToRatio :: Double -> (Integer, Integer)

+ Agda.Utils.Float: intToDouble :: Integral a => a -> Double

+ Agda.Utils.Float: isNegInf :: Double -> Bool

+ Agda.Utils.Float: isNegZero :: Double -> Bool

+ Agda.Utils.Float: isPosInf :: Double -> Bool

+ Agda.Utils.Float: isPosZero :: Double -> Bool

+ Agda.Utils.Float: isSafeInteger :: Double -> Bool

+ Agda.Utils.Float: ratioToDouble :: Integer -> Integer -> Double

+ Agda.Utils.Haskell.Syntax: Ann :: Exp -> Type -> Exp

+ Agda.Utils.IO: instance Agda.Utils.IO.CatchIO m => Agda.Utils.IO.CatchIO (Control.Monad.Trans.State.Lazy.StateT s m)

+ Agda.Utils.Impossible: impossible :: HasCallStack => Impossible

+ Agda.Utils.Impossible: instance Control.DeepSeq.NFData Agda.Utils.Impossible.Impossible

+ Agda.Utils.Impossible: instance GHC.Classes.Eq Agda.Utils.Impossible.Impossible

+ Agda.Utils.Impossible: instance GHC.Classes.Ord Agda.Utils.Impossible.Impossible

+ Agda.Utils.List: init1 :: a -> [a] -> [a]

+ Agda.Utils.List: initLast1 :: a -> [a] -> ([a], a)

+ Agda.Utils.List: initWithDefault :: [a] -> [a] -> [a]

+ Agda.Utils.List: last1 :: a -> [a] -> a

+ Agda.Utils.List: lastWithDefault :: a -> [a] -> a

+ Agda.Utils.List: mergeStrictlyOrderedBy :: (a -> a -> Bool) -> [a] -> [a] -> Maybe [a]

+ Agda.Utils.List: nubAndDuplicatesOn :: Ord b => (a -> b) -> [a] -> ([a], [a])

+ Agda.Utils.List: nubM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a]

+ Agda.Utils.List1: (!!) :: NonEmpty a -> Int -> a

+ Agda.Utils.List1: (<|) :: a -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: allEqual :: Eq a => List1 a -> Bool

+ Agda.Utils.List1: append :: List1 a -> [a] -> List1 a

+ Agda.Utils.List1: break :: (a -> Bool) -> NonEmpty a -> ([a], [a])

+ Agda.Utils.List1: catMaybes :: List1 (Maybe a) -> [a]

+ Agda.Utils.List1: concat :: [List1 a] -> [a]

+ Agda.Utils.List1: cons :: a -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: cycle :: NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: drop :: Int -> NonEmpty a -> [a]

+ Agda.Utils.List1: dropWhile :: (a -> Bool) -> NonEmpty a -> [a]

+ Agda.Utils.List1: filter :: (a -> Bool) -> NonEmpty a -> [a]

+ Agda.Utils.List1: fromList :: [a] -> NonEmpty a

+ Agda.Utils.List1: group :: (Foldable f, Eq a) => f a -> [NonEmpty a]

+ Agda.Utils.List1: group1 :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a)

+ Agda.Utils.List1: groupAllWith :: Ord b => (a -> b) -> [a] -> [NonEmpty a]

+ Agda.Utils.List1: groupAllWith1 :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)

+ Agda.Utils.List1: groupBy :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a]

+ Agda.Utils.List1: groupBy' :: forall a. (a -> a -> Bool) -> [a] -> [List1 a]

+ Agda.Utils.List1: groupBy1 :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a)

+ Agda.Utils.List1: groupWith :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a]

+ Agda.Utils.List1: groupWith1 :: Eq b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)

+ Agda.Utils.List1: head :: NonEmpty a -> a

+ Agda.Utils.List1: ifNotNull :: [a] -> (List1 a -> b) -> b -> b

+ Agda.Utils.List1: ifNull :: [a] -> b -> (List1 a -> b) -> b

+ Agda.Utils.List1: infixl 9 !!

+ Agda.Utils.List1: infixr 5 :|

+ Agda.Utils.List1: init :: NonEmpty a -> [a]

+ Agda.Utils.List1: initLast :: List1 a -> ([a], a)

+ Agda.Utils.List1: inits :: Foldable f => f a -> NonEmpty [a]

+ Agda.Utils.List1: insert :: (Foldable f, Ord a) => a -> f a -> NonEmpty a

+ Agda.Utils.List1: intersperse :: a -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool

+ Agda.Utils.List1: iterate :: (a -> a) -> a -> NonEmpty a

+ Agda.Utils.List1: last :: NonEmpty a -> a

+ Agda.Utils.List1: lefts :: List1 (Either a b) -> [a]

+ Agda.Utils.List1: length :: NonEmpty a -> Int

+ Agda.Utils.List1: map :: (a -> b) -> NonEmpty a -> NonEmpty b

+ Agda.Utils.List1: mapMaybe :: (a -> Maybe b) -> List1 a -> [b]

+ Agda.Utils.List1: nonEmpty :: [a] -> Maybe (NonEmpty a)

+ Agda.Utils.List1: nub :: Eq a => NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: nubM :: Monad m => (a -> a -> m Bool) -> List1 a -> m (List1 a)

+ Agda.Utils.List1: partition :: (a -> Bool) -> NonEmpty a -> ([a], [a])

+ Agda.Utils.List1: partitionEithers :: List1 (Either a b) -> ([a], [b])

+ Agda.Utils.List1: pattern (:|) :: () => a -> [a] -> NonEmpty a

+ Agda.Utils.List1: prepend :: [a] -> List1 a -> List1 a

+ Agda.Utils.List1: repeat :: a -> NonEmpty a

+ Agda.Utils.List1: reverse :: NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: rights :: List1 (Either a b) -> [b]

+ Agda.Utils.List1: scanl :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b

+ Agda.Utils.List1: scanl1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: scanr :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b

+ Agda.Utils.List1: scanr1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: singleton :: a -> List1 a

+ Agda.Utils.List1: snoc :: [a] -> a -> List1 a

+ Agda.Utils.List1: some1 :: Alternative f => f a -> f (NonEmpty a)

+ Agda.Utils.List1: sort :: Ord a => NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: sortBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: sortWith :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a

+ Agda.Utils.List1: span :: (a -> Bool) -> NonEmpty a -> ([a], [a])

+ Agda.Utils.List1: splitAt :: Int -> NonEmpty a -> ([a], [a])

+ Agda.Utils.List1: tail :: NonEmpty a -> [a]

+ Agda.Utils.List1: tails :: Foldable f => f a -> NonEmpty [a]

+ Agda.Utils.List1: take :: Int -> NonEmpty a -> [a]

+ Agda.Utils.List1: takeWhile :: (a -> Bool) -> NonEmpty a -> [a]

+ Agda.Utils.List1: toList :: NonEmpty a -> [a]

+ Agda.Utils.List1: transpose :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)

+ Agda.Utils.List1: type List1 = NonEmpty

+ Agda.Utils.List1: uncons :: NonEmpty a -> (a, Maybe (NonEmpty a))

+ Agda.Utils.List1: unfold :: (a -> (b, Maybe a)) -> a -> NonEmpty b

+ Agda.Utils.List1: unfoldr :: (a -> (b, Maybe a)) -> a -> NonEmpty b

+ Agda.Utils.List1: union :: Eq a => List1 a -> List1 a -> List1 a

+ Agda.Utils.List1: unlessNull :: Null m => [a] -> (List1 a -> m) -> m

+ Agda.Utils.List1: unzip :: Functor f => f (a, b) -> (f a, f b)

+ Agda.Utils.List1: xor :: NonEmpty Bool -> Bool

+ Agda.Utils.List1: zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b)

+ Agda.Utils.List1: zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c

+ Agda.Utils.List1: zipWithM :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m (List1 c)

+ Agda.Utils.List1: zipWithM_ :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m ()

+ Agda.Utils.List2: List2 :: a -> a -> [a] -> List2 a

+ Agda.Utils.List2: break :: (a -> Bool) -> List2 a -> ([a], [a])

+ Agda.Utils.List2: data List2 a

+ Agda.Utils.List2: fromList1 :: List1 a -> List2 a

+ Agda.Utils.List2: fromList1Maybe :: List1 a -> Maybe (List2 a)

+ Agda.Utils.List2: fromListMaybe :: [a] -> Maybe (List2 a)

+ Agda.Utils.List2: head :: List2 a -> a

+ Agda.Utils.List2: init :: List2 a -> List1 a

+ Agda.Utils.List2: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.List2.List2 a)

+ Agda.Utils.List2: instance Data.Data.Data a => Data.Data.Data (Agda.Utils.List2.List2 a)

+ Agda.Utils.List2: instance Data.Foldable.Foldable Agda.Utils.List2.List2

+ Agda.Utils.List2: instance Data.Traversable.Traversable Agda.Utils.List2.List2

+ Agda.Utils.List2: instance GHC.Base.Functor Agda.Utils.List2.List2

+ Agda.Utils.List2: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.List2.List2 a)

+ Agda.Utils.List2: instance GHC.Classes.Ord a => GHC.Classes.Ord (Agda.Utils.List2.List2 a)

+ Agda.Utils.List2: instance GHC.Exts.IsList (Agda.Utils.List2.List2 a)

+ Agda.Utils.List2: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.List2.List2 a)

+ Agda.Utils.List2: tail :: List2 a -> List1 a

+ Agda.Utils.List2: toList :: IsList l => l -> [Item l]

+ Agda.Utils.List2: toList1 :: List2 a -> List1 a

+ Agda.Utils.ListT: allListT :: Monad m => ListT m a -> (a -> m Bool) -> m Bool

+ Agda.Utils.ListT: anyListT :: Monad m => ListT m a -> (a -> m Bool) -> m Bool

+ Agda.Utils.ListT: unmapListT :: (ListT m a -> ListT n b) -> m (Maybe (a, ListT m a)) -> n (Maybe (b, ListT n b))

+ Agda.Utils.Map: adjustM :: (Functor f, Ord k) => (v -> f v) -> k -> Map k v -> f (Map k v)

+ Agda.Utils.Map: adjustM' :: (Functor f, Ord k) => (v -> f (a, v)) -> k -> Map k v -> f (a, Map k v)

+ Agda.Utils.Maybe: liftMaybe :: Alternative f => Maybe a -> f a

+ Agda.Utils.Monad: guardWithError :: MonadError e m => e -> Bool -> m ()

+ Agda.Utils.Monad: scatterMP :: (MonadPlus m, Foldable t) => m (t a) -> m a

+ Agda.Utils.Null: instance (Agda.Utils.Null.Null a, Agda.Utils.Null.Null b, Agda.Utils.Null.Null c) => Agda.Utils.Null.Null (a, b, c)

+ Agda.Utils.Null: instance (Agda.Utils.Null.Null a, Agda.Utils.Null.Null b, Agda.Utils.Null.Null c, Agda.Utils.Null.Null d) => Agda.Utils.Null.Null (a, b, c, d)

+ Agda.Utils.Permutation: instance Control.DeepSeq.NFData Agda.Utils.Permutation.Permutation

+ Agda.Utils.Permutation: instance GHC.Generics.Generic Agda.Utils.Permutation.Permutation

+ Agda.Utils.Permutation: topoSortM :: Monad m => (a -> a -> m Bool) -> [a] -> m (Maybe Permutation)

+ Agda.Utils.Pretty: hsepWith :: Doc -> Doc -> Doc -> Doc

+ Agda.Utils.Pretty: instance (Agda.Utils.Pretty.Pretty k, Agda.Utils.Pretty.Pretty v) => Agda.Utils.Pretty.Pretty (Data.Map.Internal.Map k v)

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty Data.IntSet.Internal.IntSet

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty Data.Text.Internal.Text

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty GHC.Types.Double

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty GHC.Word.Word64

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (Agda.Utils.List1.List1 a)

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (Data.IntMap.Internal.IntMap a)

+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (Data.Set.Internal.Set a)

+ Agda.Utils.Pretty: parensNonEmpty :: Doc -> Doc

+ Agda.Utils.Pretty: prettyAssign :: (Pretty k, Pretty v) => (k, v) -> Doc

+ Agda.Utils.Pretty: prettyMap :: (Pretty k, Pretty v) => [(k, v)] -> Doc

+ Agda.Utils.Pretty: prettySet :: Pretty a => [a] -> Doc

+ Agda.Utils.RangeMap: PairInt :: Pair Int a -> PairInt a

+ Agda.Utils.RangeMap: RangeMap :: Map Int (PairInt a) -> RangeMap a

+ Agda.Utils.RangeMap: [rangeMap] :: RangeMap a -> Map Int (PairInt a)

+ Agda.Utils.RangeMap: class IsBasicRangeMap a m | m -> a

+ Agda.Utils.RangeMap: coveringRange :: IsBasicRangeMap a m => m -> Maybe Range

+ Agda.Utils.RangeMap: fromNonOverlappingNonEmptyAscendingList :: [(Range, a)] -> RangeMap a

+ Agda.Utils.RangeMap: insert :: (a -> a -> a) -> Range -> a -> RangeMap a -> RangeMap a

+ Agda.Utils.RangeMap: insideAndOutside :: Range -> RangeMap a -> (RangeMap a, RangeMap a)

+ Agda.Utils.RangeMap: instance Agda.Utils.Null.Null (Agda.Utils.RangeMap.RangeMap a)

+ Agda.Utils.RangeMap: instance Agda.Utils.RangeMap.IsBasicRangeMap a (Agda.Utils.RangeMap.RangeMap a)

+ Agda.Utils.RangeMap: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.RangeMap.PairInt a)

+ Agda.Utils.RangeMap: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.RangeMap.RangeMap a)

+ Agda.Utils.RangeMap: instance GHC.Base.Semigroup a => GHC.Base.Monoid (Agda.Utils.RangeMap.RangeMap a)

+ Agda.Utils.RangeMap: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.Utils.RangeMap.RangeMap a)

+ Agda.Utils.RangeMap: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.RangeMap.PairInt a)

+ Agda.Utils.RangeMap: instance GHC.Show.Show a => GHC.Show.Show (Agda.Utils.RangeMap.RangeMap a)

+ Agda.Utils.RangeMap: newtype PairInt a

+ Agda.Utils.RangeMap: newtype RangeMap a

+ Agda.Utils.RangeMap: rangeMapInvariant :: RangeMap a -> Bool

+ Agda.Utils.RangeMap: restrictTo :: Range -> RangeMap a -> RangeMap a

+ Agda.Utils.RangeMap: several :: (IsBasicRangeMap a hl, Monoid hl) => [Ranges] -> a -> hl

+ Agda.Utils.RangeMap: singleton :: IsBasicRangeMap a m => Ranges -> a -> m

+ Agda.Utils.RangeMap: splitAt :: Int -> RangeMap a -> (RangeMap a, RangeMap a)

+ Agda.Utils.RangeMap: toList :: IsBasicRangeMap a m => m -> [(Range, a)]

+ Agda.Utils.RangeMap: toMap :: IsBasicRangeMap a m => m -> IntMap a

+ Agda.Utils.Semigroup: (<>) :: Semigroup a => a -> a -> a

+ Agda.Utils.Semigroup: class Semigroup a

+ Agda.Utils.Semigroup: infixr 6 <>

+ Agda.Utils.Semigroup: instance (GHC.Base.Applicative m, GHC.Base.Semigroup doc) => GHC.Base.Semigroup (Control.Monad.Trans.Reader.ReaderT s m doc)

+ Agda.Utils.Semigroup: instance (GHC.Base.Monad m, GHC.Base.Semigroup doc) => GHC.Base.Semigroup (Control.Monad.Trans.State.Lazy.StateT s m doc)

+ Agda.Utils.Singleton: class (Semigroup coll, Monoid coll, Singleton el coll) => Collection el coll | coll -> el

+ Agda.Utils.Singleton: fromList :: Collection el coll => [el] -> coll

+ Agda.Utils.Singleton: instance (GHC.Classes.Eq a, Data.Hashable.Class.Hashable a) => Agda.Utils.Singleton.Collection a (Data.HashSet.Internal.HashSet a)

+ 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 Agda.Utils.Singleton.Collection (GHC.Types.Int, a) (Data.IntMap.Internal.IntMap a)

+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Collection GHC.Types.Int Data.IntSet.Internal.IntSet

+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Collection a (Data.Semigroup.Internal.Endo [a])

+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Collection a (Data.Sequence.Internal.Seq a)

+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Collection a ([a] -> [a])

+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Collection a [a]

+ Agda.Utils.Singleton: instance GHC.Classes.Ord a => Agda.Utils.Singleton.Collection a (Data.Set.Internal.Set a)

+ Agda.Utils.Singleton: instance GHC.Classes.Ord k => Agda.Utils.Singleton.Collection (k, a) (Data.Map.Internal.Map k a)

+ Agda.Utils.Size: instance Agda.Utils.Size.Sized (Agda.Utils.List1.List1 a)

+ Agda.Utils.SmallSet: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Agda.Utils.SmallSet.SmallSet a)

+ Agda.Utils.Suffix: renderSuffix :: Suffix -> String

+ Agda.Utils.Time: instance Control.DeepSeq.NFData Agda.Utils.Time.CPUTime

+ Agda.Utils.Trie: instance (Control.DeepSeq.NFData k, Control.DeepSeq.NFData v) => Control.DeepSeq.NFData (Agda.Utils.Trie.Trie k v)

+ Agda.Utils.Tuple: Pair :: a -> a -> Pair a

+ Agda.Utils.Tuple: data Pair a

+ Agda.Utils.Tuple: instance Data.Foldable.Foldable Agda.Utils.Tuple.Pair

+ Agda.Utils.Tuple: instance Data.Traversable.Traversable Agda.Utils.Tuple.Pair

+ Agda.Utils.Tuple: instance GHC.Base.Applicative Agda.Utils.Tuple.Pair

+ Agda.Utils.Tuple: instance GHC.Base.Functor Agda.Utils.Tuple.Pair

+ Agda.Utils.Tuple: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.Utils.Tuple.Pair a)

+ Agda.Utils.Update: instance Control.Monad.Trans.Control.MonadTransControl Agda.Utils.Update.ChangeT

+ Agda.Utils.Warshall: instance (Agda.Utils.Pretty.Pretty a, Agda.Utils.Pretty.Pretty b, Agda.Utils.Pretty.Pretty c) => Agda.Utils.Pretty.Pretty (Agda.Utils.Warshall.LegendMatrix a b c)

+ Agda.Utils.Warshall: instance Agda.Utils.Pretty.Pretty Agda.Utils.Warshall.Constraint

+ Agda.Utils.Warshall: instance Agda.Utils.Pretty.Pretty Agda.Utils.Warshall.Node

+ Agda.Utils.Warshall: instance Agda.Utils.Pretty.Pretty Agda.Utils.Warshall.SizeExpr

+ Agda.Utils.Warshall: instance Agda.Utils.Pretty.Pretty Agda.Utils.Warshall.Weight

+ Agda.Utils.WithDefault: instance Control.DeepSeq.NFData (Agda.Utils.WithDefault.WithDefault b)

+ Agda.Version: instance GHC.Generics.Generic Agda.Version.AnArbitrarySymbolInThisPackage

+ Agda.Version: package :: String

- Agda.Auto.CaseSplit: class Replace o t u | t u -> o

+ Agda.Auto.CaseSplit: class Replace t u where {

- Agda.Auto.CaseSplit: class Unify o t | t -> o

+ Agda.Auto.CaseSplit: class Unify t where {

- Agda.Auto.CaseSplit: notequal :: Unify o t => Nat -> Nat -> t -> t -> IO Bool

+ Agda.Auto.CaseSplit: notequal :: Unify t => Nat -> Nat -> t -> t -> IO Bool

- Agda.Auto.CaseSplit: notequal' :: Unify o t => t -> t -> ReaderT (Nat, Nat) (StateT (Assignments o) IO) Bool

+ Agda.Auto.CaseSplit: notequal' :: Unify t => t -> t -> ReaderT (Nat, Nat) (StateT (Assignments (UnifiesTo t)) IO) Bool

- Agda.Auto.CaseSplit: replace :: Replace o t u => Nat -> Nat -> MExp o -> t -> u

+ Agda.Auto.CaseSplit: replace :: Replace t u => Nat -> Nat -> MExp (ReplaceWith t u) -> t -> u

- Agda.Auto.CaseSplit: replace' :: Replace o t u => Nat -> MExp o -> t -> Reader (Nat, Nat) u

+ Agda.Auto.CaseSplit: replace' :: Replace t u => Nat -> MExp (ReplaceWith t u) -> t -> Reader (Nat, Nat) u

- Agda.Auto.CaseSplit: unify :: Unify o t => t -> t -> Maybe (Assignments o)

+ Agda.Auto.CaseSplit: unify :: Unify t => t -> t -> Maybe (Assignments (UnifiesTo t))

- Agda.Auto.CaseSplit: unify' :: Unify o t => t -> t -> StateT (Assignments o) Maybe ()

+ Agda.Auto.CaseSplit: unify' :: Unify t => t -> t -> StateT (Assignments (UnifiesTo t)) Maybe ()

- Agda.Auto.NarrowingSearch: class Trav a blk | a -> blk

+ Agda.Auto.NarrowingSearch: class Trav a where {

- Agda.Auto.NarrowingSearch: trav :: (Trav a blk, Monad m) => (forall b. Trav b blk => MM b blk -> m ()) -> a -> m ()

+ Agda.Auto.NarrowingSearch: trav :: (Trav a, Monad m) => (forall b. TravWith b (Block a) => MM b (Block b) -> m ()) -> a -> m ()

- Agda.Compiler.Backend: AmbiguousModule :: QName -> NonEmpty ModuleName -> TypeError

+ Agda.Compiler.Backend: AmbiguousModule :: QName -> List1 ModuleName -> TypeError

- Agda.Compiler.Backend: AmbiguousName :: QName -> NonEmpty QName -> TypeError

+ Agda.Compiler.Backend: AmbiguousName :: QName -> List1 QName -> TypeError

- Agda.Compiler.Backend: AmbiguousParseForApplication :: [Expr] -> [Expr] -> TypeError

+ Agda.Compiler.Backend: AmbiguousParseForApplication :: List2 Expr -> List1 Expr -> TypeError

- Agda.Compiler.Backend: Axiom :: Defn

+ Agda.Compiler.Backend: Axiom :: Bool -> Defn

- Agda.Compiler.Backend: Backend' :: String -> Maybe String -> opts -> [OptDescr (Flag opts)] -> (opts -> Bool) -> (opts -> TCM env) -> (env -> IsMain -> Map ModuleName mod -> TCM ()) -> (env -> IsMain -> ModuleName -> FilePath -> TCM (Recompile menv mod)) -> (env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod) -> (env -> menv -> IsMain -> Definition -> TCM def) -> Bool -> (QName -> TCM Bool) -> Backend' opts env menv mod def

+ Agda.Compiler.Backend: Backend' :: String -> Maybe String -> opts -> [OptDescr (Flag opts)] -> (opts -> Bool) -> (opts -> TCM env) -> (env -> IsMain -> Map ModuleName mod -> TCM ()) -> (env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)) -> (env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod) -> (env -> menv -> IsMain -> Definition -> TCM def) -> Bool -> (QName -> TCM Bool) -> Backend' opts env menv mod def

- Agda.Compiler.Backend: BlockedOnMeta :: TCState -> MetaId -> UnquoteError

+ Agda.Compiler.Backend: BlockedOnMeta :: TCState -> Blocker -> UnquoteError

- Agda.Compiler.Backend: Candidate :: Term -> Type -> Bool -> Candidate

+ Agda.Compiler.Backend: Candidate :: CandidateKind -> Term -> Type -> Bool -> Candidate

- Agda.Compiler.Backend: CannotEliminateWithPattern :: NamedArg Pattern -> Type -> TypeError

+ Agda.Compiler.Backend: CannotEliminateWithPattern :: Maybe Blocker -> NamedArg Pattern -> Type -> TypeError

- Agda.Compiler.Backend: CannotResolveAmbiguousPatternSynonym :: NonEmpty (QName, PatternSynDefn) -> TypeError

+ Agda.Compiler.Backend: CannotResolveAmbiguousPatternSynonym :: List1 (QName, PatternSynDefn) -> TypeError

- Agda.Compiler.Backend: CantResolveOverloadedConstructorsTargetingSameDatatype :: QName -> [QName] -> TypeError

+ Agda.Compiler.Backend: CantResolveOverloadedConstructorsTargetingSameDatatype :: QName -> List1 QName -> TypeError

- Agda.Compiler.Backend: CheckArgs :: ExpandHidden -> Range -> [NamedArg Expr] -> Type -> Type -> ([Maybe Range] -> Elims -> Type -> CheckedTarget -> TCM Term) -> TypeCheckingProblem

+ Agda.Compiler.Backend: CheckArgs :: Comparison -> ExpandHidden -> Range -> [NamedArg Expr] -> Type -> Type -> (ArgsCheckState CheckedTarget -> TCM Term) -> TypeCheckingProblem

- Agda.Compiler.Backend: CheckFunDef :: Delayed -> DefInfo -> QName -> [Clause] -> Constraint

+ Agda.Compiler.Backend: CheckFunDef :: Delayed -> DefInfo -> QName -> [Clause] -> TCErr -> Constraint

- Agda.Compiler.Backend: CheckFunDefCall :: Range -> QName -> [Clause] -> Call

+ Agda.Compiler.Backend: CheckFunDefCall :: Range -> QName -> [Clause] -> Bool -> Call

- Agda.Compiler.Backend: CheckLambda :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> Expr -> Type -> TypeCheckingProblem

+ Agda.Compiler.Backend: CheckLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> Expr -> Type -> TypeCheckingProblem

- Agda.Compiler.Backend: CheckProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> NonEmpty QName -> Args -> Type -> Int -> Term -> Type -> TypeCheckingProblem

+ Agda.Compiler.Backend: CheckProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> List1 QName -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TypeCheckingProblem

- Agda.Compiler.Backend: ClashingDefinition :: QName -> QName -> TypeError

+ Agda.Compiler.Backend: ClashingDefinition :: QName -> QName -> Maybe NiceDeclaration -> TypeError

- Agda.Compiler.Backend: DSizeVar :: Nat -> Offset -> DeepSizeView

+ Agda.Compiler.Backend: DSizeVar :: ProjectedVar -> Offset -> DeepSizeView

- Agda.Compiler.Backend: EnterSection :: !ModuleInfo -> !ModuleName -> !Telescope -> TypeCheckAction

+ Agda.Compiler.Backend: EnterSection :: !ModuleName -> !Telescope -> TypeCheckAction

- Agda.Compiler.Backend: ExtLamInfo :: ModuleName -> !Maybe System -> ExtLamInfo

+ Agda.Compiler.Backend: ExtLamInfo :: ModuleName -> Bool -> !Maybe System -> ExtLamInfo

- Agda.Compiler.Backend: FindInstance :: MetaId -> Maybe MetaId -> Maybe [Candidate] -> Constraint

+ Agda.Compiler.Backend: FindInstance :: MetaId -> Maybe [Candidate] -> Constraint

- Agda.Compiler.Backend: FixityInRenamingModule :: NonEmpty Range -> Warning

+ Agda.Compiler.Backend: FixityInRenamingModule :: List1 Range -> Warning

- Agda.Compiler.Backend: Interface :: Hash -> Text -> FileType -> [(ModuleName, Hash)] -> ModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> DisplayForms -> Map QName String -> Maybe String -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface

+ Agda.Compiler.Backend: Interface :: Hash -> Text -> FileType -> [(ModuleName, Hash)] -> ModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> DisplayForms -> Map QName Text -> Maybe Text -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface

- Agda.Compiler.Backend: MetaInfo :: Closure Range -> RunMetaOccursCheck -> MetaNameSuggestion -> Arg DoGeneralize -> MetaInfo

+ Agda.Compiler.Backend: MetaInfo :: Closure Range -> Modality -> RunMetaOccursCheck -> MetaNameSuggestion -> Arg DoGeneralize -> MetaInfo

- Agda.Compiler.Backend: ModuleDoesntExport :: QName -> [ImportedName] -> Warning

+ Agda.Compiler.Backend: ModuleDoesntExport :: QName -> [Name] -> [Name] -> [ImportedName] -> Warning

- Agda.Compiler.Backend: ModuleInfo :: Interface -> Bool -> Bool -> ModuleInfo

+ Agda.Compiler.Backend: ModuleInfo :: Interface -> [TCWarning] -> Bool -> ModuleCheckMode -> ModuleInfo

- Agda.Compiler.Backend: NoParseForApplication :: [Expr] -> TypeError

+ Agda.Compiler.Backend: NoParseForApplication :: List2 Expr -> TypeError

- Agda.Compiler.Backend: NoParseForLHS :: LHSOrPatSyn -> Pattern -> TypeError

+ Agda.Compiler.Backend: NoParseForLHS :: LHSOrPatSyn -> [Pattern] -> Pattern -> TypeError

- Agda.Compiler.Backend: OpenThing :: CheckpointId -> a -> Open a

+ Agda.Compiler.Backend: OpenThing :: CheckpointId -> Map CheckpointId Substitution -> ModuleNameHash -> a -> Open a

- Agda.Compiler.Backend: PConstr :: Set ProblemId -> Closure Constraint -> ProblemConstraint

+ Agda.Compiler.Backend: PConstr :: Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint

- Agda.Compiler.Backend: PInf :: NLPSort

+ Agda.Compiler.Backend: PInf :: IsFibrant -> Integer -> NLPSort

- Agda.Compiler.Backend: PatternErr :: TCErr

+ Agda.Compiler.Backend: PatternErr :: Blocker -> TCErr

- Agda.Compiler.Backend: PersistentTCSt :: DecodedModules -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState

+ Agda.Compiler.Backend: PersistentTCSt :: !DecodedModules -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState

- Agda.Compiler.Backend: PostScopeState :: !CompressedFile -> !DisambiguatedNames -> !MetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe ModuleName -> !TempInstanceTable -> !ConcreteNames -> !Map RawName [RawName] -> !Map Name [RawName] -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState

+ Agda.Compiler.Backend: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !MetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe ModuleName -> !TempInstanceTable -> !ConcreteNames -> !Map RawName [RawName] -> !Map Name [RawName] -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState

- Agda.Compiler.Backend: PostponedTypeCheckingProblem :: Closure TypeCheckingProblem -> TCM Bool -> MetaInstantiation

+ Agda.Compiler.Backend: PostponedTypeCheckingProblem :: Closure TypeCheckingProblem -> MetaInstantiation

- Agda.Compiler.Backend: PreScopeState :: !CompressedFile -> !Signature -> !Set ModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName String -> !Map QName String -> !Maybe String -> !Set QName -> PreScopeState

+ Agda.Compiler.Backend: PreScopeState :: !HighlightingInfo -> !Signature -> !Set ModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName Text -> !Map QName Text -> !Maybe Text -> !Set QName -> !Map FilePath ProjectConfig -> !Map FilePath AgdaLibFile -> PreScopeState

- Agda.Compiler.Backend: Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> Maybe Induction -> IsAbstract -> CompKit -> Defn

+ Agda.Compiler.Backend: Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> IsAbstract -> CompKit -> Defn

- Agda.Compiler.Backend: RewriteRule :: QName -> Telescope -> QName -> PElims -> Term -> Type -> RewriteRule

+ Agda.Compiler.Backend: RewriteRule :: QName -> Telescope -> QName -> PElims -> Term -> Type -> Bool -> RewriteRule

- Agda.Compiler.Backend: SomeGeneralizableArgs :: Int -> NumGeneralizableArgs

+ Agda.Compiler.Backend: SomeGeneralizableArgs :: !Int -> NumGeneralizableArgs

- Agda.Compiler.Backend: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> !Int -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Bool -> Maybe BackendName -> TCEnv

+ Agda.Compiler.Backend: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> ReduceDefs -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Maybe BackendName -> Bool -> TCEnv

- Agda.Compiler.Backend: TCWarning :: Range -> Warning -> Doc -> Bool -> TCWarning

+ Agda.Compiler.Backend: TCWarning :: CallStack -> Range -> Warning -> Doc -> Bool -> TCWarning

- Agda.Compiler.Backend: TypeError :: TCState -> Closure TypeError -> TCErr

+ Agda.Compiler.Backend: TypeError :: CallStack -> TCState -> Closure TypeError -> TCErr

- Agda.Compiler.Backend: UnificationStuck :: QName -> Telescope -> Args -> Args -> [UnificationFailure] -> SplitError

+ Agda.Compiler.Backend: UnificationStuck :: Maybe Blocker -> QName -> Telescope -> Args -> Args -> [UnificationFailure] -> SplitError

- Agda.Compiler.Backend: UnquoteTactic :: Maybe MetaId -> Term -> Term -> Type -> Constraint

+ Agda.Compiler.Backend: UnquoteTactic :: Term -> Term -> Type -> Constraint

- Agda.Compiler.Backend: UserWarning :: String -> Warning

+ Agda.Compiler.Backend: UserWarning :: Text -> Warning

- Agda.Compiler.Backend: [Backend] :: Backend' opts env menv mod def -> Backend

+ Agda.Compiler.Backend: [Backend] :: NFData opts => Backend' opts env menv mod def -> Backend

- Agda.Compiler.Backend: [iImportWarning] :: Interface -> Maybe String

+ Agda.Compiler.Backend: [iImportWarning] :: Interface -> Maybe Text

- Agda.Compiler.Backend: [iUserWarnings] :: Interface -> Map QName String

+ Agda.Compiler.Backend: [iUserWarnings] :: Interface -> Map QName Text

- Agda.Compiler.Backend: [miWarnings] :: ModuleInfo -> Bool

+ Agda.Compiler.Backend: [miWarnings] :: ModuleInfo -> [TCWarning]

- Agda.Compiler.Backend: [preModule] :: Backend' opts env menv mod def -> env -> IsMain -> ModuleName -> FilePath -> TCM (Recompile menv mod)

+ Agda.Compiler.Backend: [preModule] :: Backend' opts env menv mod def -> env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)

- Agda.Compiler.Backend: [stDecodedModules] :: PersistentTCState -> DecodedModules

+ Agda.Compiler.Backend: [stDecodedModules] :: PersistentTCState -> !DecodedModules

- Agda.Compiler.Backend: [stPostSyntaxInfo] :: PostScopeState -> !CompressedFile

+ Agda.Compiler.Backend: [stPostSyntaxInfo] :: PostScopeState -> !HighlightingInfo

- Agda.Compiler.Backend: [stPreImportedUserWarnings] :: PreScopeState -> !Map QName String

+ Agda.Compiler.Backend: [stPreImportedUserWarnings] :: PreScopeState -> !Map QName Text

- Agda.Compiler.Backend: [stPreLocalUserWarnings] :: PreScopeState -> !Map QName String

+ Agda.Compiler.Backend: [stPreLocalUserWarnings] :: PreScopeState -> !Map QName Text

- Agda.Compiler.Backend: [stPreTokens] :: PreScopeState -> !CompressedFile

+ Agda.Compiler.Backend: [stPreTokens] :: PreScopeState -> !HighlightingInfo

- Agda.Compiler.Backend: [stPreWarningOnImport] :: PreScopeState -> !Maybe String

+ Agda.Compiler.Backend: [stPreWarningOnImport] :: PreScopeState -> !Maybe Text

- Agda.Compiler.Backend: addAwakeConstraint :: MonadConstraint m => Constraint -> m ()

+ Agda.Compiler.Backend: addAwakeConstraint :: MonadConstraint m => Blocker -> Constraint -> m ()

- Agda.Compiler.Backend: addAwakeConstraint' :: Constraint -> TCM ()

+ Agda.Compiler.Backend: addAwakeConstraint' :: Blocker -> Constraint -> TCM ()

- Agda.Compiler.Backend: addConstraint :: MonadConstraint m => Constraint -> m ()

+ Agda.Compiler.Backend: addConstraint :: MonadConstraint m => Blocker -> Constraint -> m ()

- Agda.Compiler.Backend: addConstraint' :: Constraint -> TCM ()

+ Agda.Compiler.Backend: addConstraint' :: Blocker -> Constraint -> TCM ()

- Agda.Compiler.Backend: addConstraintTo :: Lens' Constraints TCState -> Constraint -> TCM ()

+ Agda.Compiler.Backend: addConstraintTo :: Lens' Constraints TCState -> Blocker -> Constraint -> TCM ()

- Agda.Compiler.Backend: addCtx :: MonadAddContext m => Name -> Dom Type -> m a -> m a

+ Agda.Compiler.Backend: addCtx :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Name -> Dom Type -> m a -> m a

- Agda.Compiler.Backend: addLetBinding' :: MonadAddContext m => Name -> Term -> Dom Type -> m a -> m a

+ Agda.Compiler.Backend: addLetBinding' :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Name -> Term -> Dom Type -> m a -> m a

- Agda.Compiler.Backend: askTC :: MonadTCEnv m => m TCEnv

+ Agda.Compiler.Backend: askTC :: (MonadTCEnv m, MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv

- Agda.Compiler.Backend: backendInteraction :: [Backend] -> (TCM (Maybe Interface) -> TCM ()) -> TCM (Maybe Interface) -> TCM ()

+ Agda.Compiler.Backend: backendInteraction :: AbsolutePath -> [Backend] -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()

- Agda.Compiler.Backend: buildConstraint :: Constraint -> TCM ProblemConstraint

+ Agda.Compiler.Backend: buildConstraint :: Blocker -> Constraint -> TCM ProblemConstraint

- Agda.Compiler.Backend: buildProblemConstraint :: (MonadTCEnv m, ReadTCState m) => Set ProblemId -> Constraint -> m ProblemConstraint

+ Agda.Compiler.Backend: buildProblemConstraint :: (MonadTCEnv m, ReadTCState m) => Set ProblemId -> Blocker -> Constraint -> m ProblemConstraint

- Agda.Compiler.Backend: buildProblemConstraint_ :: (MonadTCEnv m, ReadTCState m) => Constraint -> m ProblemConstraint

+ Agda.Compiler.Backend: buildProblemConstraint_ :: (MonadTCEnv m, ReadTCState m) => Blocker -> Constraint -> m ProblemConstraint

- Agda.Compiler.Backend: cachingStarts :: (MonadTCState m, ReadTCState m) => m ()

+ Agda.Compiler.Backend: cachingStarts :: (MonadDebug m, MonadTCState m, ReadTCState m) => m ()

- Agda.Compiler.Backend: callBackend :: String -> IsMain -> Interface -> TCM ()

+ Agda.Compiler.Backend: callBackend :: String -> IsMain -> CheckResult -> TCM ()

- Agda.Compiler.Backend: catchPatternErr :: MonadConstraint m => m a -> m a -> m a

+ Agda.Compiler.Backend: catchPatternErr :: MonadBlock m => (Blocker -> m a) -> m a -> m a

- Agda.Compiler.Backend: class (MonadTCEnv m, ReadTCState m, MonadError TCErr m, HasOptions m, MonadDebug m) => MonadConstraint m

+ Agda.Compiler.Backend: class (MonadTCEnv m, ReadTCState m, MonadError TCErr m, MonadBlock m, HasOptions m, MonadDebug m) => MonadConstraint m

- Agda.Compiler.Backend: constructorForm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => Term -> m Term

+ Agda.Compiler.Backend: constructorForm :: HasBuiltins m => Term -> m Term

- Agda.Compiler.Backend: defaultAddLetBinding' :: MonadTCEnv m => Name -> Term -> Dom Type -> m a -> m a

+ Agda.Compiler.Backend: defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Name -> Term -> Dom Type -> m a -> m a

- Agda.Compiler.Backend: defaultGetRewriteRulesFor :: Monad m => m TCState -> QName -> m RewriteRules

+ Agda.Compiler.Backend: defaultGetRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m RewriteRules

- Agda.Compiler.Backend: escapeContext :: MonadAddContext m => Empty -> Int -> m a -> m a

+ Agda.Compiler.Backend: escapeContext :: MonadAddContext m => Impossible -> Int -> m a -> m a

- Agda.Compiler.Backend: formatDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m String

+ Agda.Compiler.Backend: formatDebugMessage :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> TCM Doc -> m String

- Agda.Compiler.Backend: fresh :: MonadFresh i m => m i

+ Agda.Compiler.Backend: fresh :: (MonadFresh i m, MonadTrans t, MonadFresh i n, t n ~ m) => m i

- Agda.Compiler.Backend: freshInteractionId :: MonadInteractionPoints m => m InteractionId

+ Agda.Compiler.Backend: freshInteractionId :: (MonadInteractionPoints m, MonadTrans t, MonadInteractionPoints n, t n ~ m) => m InteractionId

- Agda.Compiler.Backend: genericDocError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> m a

+ Agda.Compiler.Backend: genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a

- Agda.Compiler.Backend: genericError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => String -> m a

+ Agda.Compiler.Backend: genericError :: (HasCallStack, MonadTCError m) => String -> m a

- Agda.Compiler.Backend: getBuiltinThing :: HasBuiltins m => String -> m (Maybe (Builtin PrimFun))

+ Agda.Compiler.Backend: getBuiltinThing :: (HasBuiltins m, MonadTrans t, HasBuiltins n, t n ~ m) => String -> m (Maybe (Builtin PrimFun))

- Agda.Compiler.Backend: getCompiled :: QName -> TCM (Maybe Compiled)

+ Agda.Compiler.Backend: getCompiled :: HasConstInfo m => QName -> m (Maybe Compiled)

- Agda.Compiler.Backend: getCompiledArgUse :: QName -> TCM [Bool]

+ Agda.Compiler.Backend: getCompiledArgUse :: HasConstInfo m => QName -> m (Maybe [ArgUsage])

- Agda.Compiler.Backend: getDecodedModule :: TopLevelModuleName -> TCM (Maybe Interface)

+ Agda.Compiler.Backend: getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)

- Agda.Compiler.Backend: getErasedConArgs :: QName -> TCM [Bool]

+ Agda.Compiler.Backend: getErasedConArgs :: HasConstInfo m => QName -> m [Bool]

- Agda.Compiler.Backend: getInteractionOutputCallback :: TCM InteractionOutputCallback

+ Agda.Compiler.Backend: getInteractionOutputCallback :: ReadTCState m => m InteractionOutputCallback

- Agda.Compiler.Backend: getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m) => MetaId -> m Type

+ Agda.Compiler.Backend: getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m) => MetaId -> m Type

- Agda.Compiler.Backend: getOpen :: (Subst Term a, MonadTCEnv m) => Open a -> m a

+ Agda.Compiler.Backend: getOpen :: (TermSubst a, MonadTCEnv m) => Open a -> m a

- Agda.Compiler.Backend: getTC :: MonadTCState m => m TCState

+ Agda.Compiler.Backend: getTC :: (MonadTCState m, MonadTrans t, MonadTCState n, t n ~ m) => m TCState

- Agda.Compiler.Backend: getTCState :: ReadTCState m => m TCState

+ Agda.Compiler.Backend: getTCState :: (ReadTCState m, MonadTrans t, ReadTCState n, t n ~ m) => m TCState

- Agda.Compiler.Backend: getTreeless :: QName -> TCM (Maybe TTerm)

+ Agda.Compiler.Backend: getTreeless :: HasConstInfo m => QName -> m (Maybe TTerm)

- Agda.Compiler.Backend: getUserWarnings :: ReadTCState m => m (Map QName String)

+ Agda.Compiler.Backend: getUserWarnings :: ReadTCState m => m (Map QName Text)

- Agda.Compiler.Backend: getVerbosity :: (MonadDebug m, HasOptions m) => m Verbosity

+ Agda.Compiler.Backend: getVerbosity :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => m Verbosity

- Agda.Compiler.Backend: getVisitedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)

+ Agda.Compiler.Backend: getVisitedModule :: ReadTCState m => TopLevelModuleName -> m (Maybe ModuleInfo)

- Agda.Compiler.Backend: getVisitedModules :: TCM VisitedModules

+ Agda.Compiler.Backend: getVisitedModules :: ReadTCState m => m VisitedModules

- Agda.Compiler.Backend: highlightAsTypeChecked :: (MonadTCM tcm, ReadTCState tcm) => Range -> Range -> tcm a -> tcm a

+ Agda.Compiler.Backend: highlightAsTypeChecked :: MonadTrace m => Range -> Range -> m a -> m a

- Agda.Compiler.Backend: ifTopLevelAndHighlightingLevelIs :: MonadTCM tcm => HighlightingLevel -> tcm () -> tcm ()

+ Agda.Compiler.Backend: ifTopLevelAndHighlightingLevelIs :: MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()

- Agda.Compiler.Backend: ifTopLevelAndHighlightingLevelIsOr :: MonadTCM tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()

+ Agda.Compiler.Backend: ifTopLevelAndHighlightingLevelIsOr :: MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()

- Agda.Compiler.Backend: internalError :: MonadTCM tcm => String -> tcm a

+ Agda.Compiler.Backend: internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a

- Agda.Compiler.Backend: isDebugPrinting :: (MonadDebug m, MonadTCEnv m) => m Bool

+ Agda.Compiler.Backend: isDebugPrinting :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => m Bool

- Agda.Compiler.Backend: liftReduce :: MonadReduce m => ReduceM a -> m a

+ Agda.Compiler.Backend: liftReduce :: (MonadReduce m, MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a

- Agda.Compiler.Backend: localTC :: MonadTCEnv m => (TCEnv -> TCEnv) -> m a -> m a

+ Agda.Compiler.Backend: localTC :: (MonadTCEnv m, MonadTransControl t, MonadTCEnv n, t n ~ m) => (TCEnv -> TCEnv) -> m a -> m a

- Agda.Compiler.Backend: locallyTCState :: ReadTCState m => Lens' a TCState -> (a -> a) -> m b -> m b

+ Agda.Compiler.Backend: locallyTCState :: (ReadTCState m, MonadTransControl t, ReadTCState n, t n ~ m) => Lens' a TCState -> (a -> a) -> m b -> m b

- Agda.Compiler.Backend: makeOpen :: MonadTCEnv m => a -> m (Open a)

+ Agda.Compiler.Backend: makeOpen :: (ReadTCState m, MonadTCEnv m) => a -> m (Open a)

- Agda.Compiler.Backend: mapAbstraction :: (Subst t a, Subst t' b, Free b, MonadAddContext m) => Dom Type -> (a -> m b) -> Abs a -> m (Abs b)

+ Agda.Compiler.Backend: mapAbstraction :: (Subst a, Subst b, MonadAddContext m) => Dom Type -> (a -> m b) -> Abs a -> m (Abs b)

- Agda.Compiler.Backend: modifyArgOccurrences :: QName -> ([Occurrence] -> [Occurrence]) -> TCM ()

+ Agda.Compiler.Backend: modifyArgOccurrences :: MonadTCState m => QName -> ([Occurrence] -> [Occurrence]) -> m ()

- Agda.Compiler.Backend: modifyGlobalDefinition :: QName -> (Definition -> Definition) -> TCM ()

+ Agda.Compiler.Backend: modifyGlobalDefinition :: MonadTCState m => QName -> (Definition -> Definition) -> m ()

- Agda.Compiler.Backend: modifyImportedSignature :: (Signature -> Signature) -> TCM ()

+ Agda.Compiler.Backend: modifyImportedSignature :: MonadTCState m => (Signature -> Signature) -> m ()

- Agda.Compiler.Backend: modifyInteractionPoints :: MonadInteractionPoints m => (InteractionPoints -> InteractionPoints) -> m ()

+ Agda.Compiler.Backend: modifyInteractionPoints :: (MonadInteractionPoints m, MonadTrans t, MonadInteractionPoints n, t n ~ m) => (InteractionPoints -> InteractionPoints) -> m ()

- Agda.Compiler.Backend: modifySignature :: (Signature -> Signature) -> TCM ()

+ Agda.Compiler.Backend: modifySignature :: MonadTCState m => (Signature -> Signature) -> m ()

- Agda.Compiler.Backend: modifyTC :: MonadTCState m => (TCState -> TCState) -> m ()

+ Agda.Compiler.Backend: modifyTC :: (MonadTCState m, MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()

- Agda.Compiler.Backend: nowDebugPrinting :: (MonadDebug m, MonadTCEnv m) => m a -> m a

+ Agda.Compiler.Backend: nowDebugPrinting :: (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => m a -> m a

- Agda.Compiler.Backend: patternViolation :: MonadError TCErr m => m a

+ Agda.Compiler.Backend: patternViolation :: (MonadBlock m, MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a

- Agda.Compiler.Backend: printHighlightingInfo :: (MonadTCM tcm, ReadTCState tcm) => RemoveTokenBasedHighlighting -> HighlightingInfo -> tcm ()

+ Agda.Compiler.Backend: printHighlightingInfo :: (MonadTrace m, MonadTrans t, MonadTrace n, t n ~ m) => RemoveTokenBasedHighlighting -> HighlightingInfo -> m ()

- Agda.Compiler.Backend: putTC :: MonadTCState m => TCState -> m ()

+ Agda.Compiler.Backend: putTC :: (MonadTCState m, MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()

- Agda.Compiler.Backend: setArgOccurrences :: QName -> [Occurrence] -> TCM ()

+ Agda.Compiler.Backend: setArgOccurrences :: MonadTCState m => QName -> [Occurrence] -> m ()

- Agda.Compiler.Backend: setCompiledArgUse :: QName -> [Bool] -> TCM ()

+ Agda.Compiler.Backend: setCompiledArgUse :: QName -> [ArgUsage] -> TCM ()

- Agda.Compiler.Backend: setCurrentRange :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) => x -> tcm a -> tcm a

+ Agda.Compiler.Backend: setCurrentRange :: (MonadTrace m, HasRange x) => x -> m a -> m a

- Agda.Compiler.Backend: setPolarity :: QName -> [Polarity] -> TCM ()

+ Agda.Compiler.Backend: setPolarity :: (MonadTCState m, MonadDebug m) => QName -> [Polarity] -> m ()

- Agda.Compiler.Backend: setSignature :: Signature -> TCM ()

+ Agda.Compiler.Backend: setSignature :: MonadTCState m => Signature -> m ()

- Agda.Compiler.Backend: sizeView :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => Term -> m SizeView

+ Agda.Compiler.Backend: sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => Term -> m SizeView

- Agda.Compiler.Backend: stImportedUserWarnings :: Lens' (Map QName String) TCState

+ Agda.Compiler.Backend: stImportedUserWarnings :: Lens' (Map QName Text) TCState

- Agda.Compiler.Backend: stLocalUserWarnings :: Lens' (Map QName String) TCState

+ Agda.Compiler.Backend: stLocalUserWarnings :: Lens' (Map QName Text) TCState

- Agda.Compiler.Backend: stSyntaxInfo :: Lens' CompressedFile TCState

+ Agda.Compiler.Backend: stSyntaxInfo :: Lens' HighlightingInfo TCState

- Agda.Compiler.Backend: stTokens :: Lens' CompressedFile TCState

+ Agda.Compiler.Backend: stTokens :: Lens' HighlightingInfo TCState

- Agda.Compiler.Backend: stWarningOnImport :: Lens' (Maybe String) TCState

+ Agda.Compiler.Backend: stWarningOnImport :: Lens' (Maybe Text) TCState

- Agda.Compiler.Backend: storeDecodedModule :: Interface -> TCM ()

+ Agda.Compiler.Backend: storeDecodedModule :: ModuleInfo -> TCM ()

- Agda.Compiler.Backend: traceCall :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Call -> tcm a -> tcm a

+ Agda.Compiler.Backend: traceCall :: MonadTrace m => Call -> m a -> m a

- Agda.Compiler.Backend: traceCallCPS :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Call -> ((a -> tcm b) -> tcm b) -> (a -> tcm b) -> tcm b

+ Agda.Compiler.Backend: traceCallCPS :: MonadTrace m => Call -> ((a -> m b) -> m b) -> (a -> m b) -> m b

- Agda.Compiler.Backend: traceCallM :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => tcm Call -> tcm a -> tcm a

+ Agda.Compiler.Backend: traceCallM :: MonadTrace m => m Call -> m a -> m a

- Agda.Compiler.Backend: traceClosureCall :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Closure Call -> tcm a -> tcm a

+ Agda.Compiler.Backend: traceClosureCall :: MonadTrace m => Closure Call -> m a -> m a

- Agda.Compiler.Backend: traceDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a

+ Agda.Compiler.Backend: traceDebugMessage :: (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> String -> m a -> m a

- Agda.Compiler.Backend: tryGetOpen :: (Subst Term a, MonadTCEnv m) => Open a -> m (Maybe a)

+ Agda.Compiler.Backend: tryGetOpen :: (TermSubst a, ReadTCState m, MonadTCEnv m) => (Substitution -> a -> Maybe a) -> Open a -> m (Maybe a)

- Agda.Compiler.Backend: type DecodedModules = Map TopLevelModuleName Interface

+ Agda.Compiler.Backend: type DecodedModules = Map TopLevelModuleName ModuleInfo

- Agda.Compiler.Backend: type DisambiguatedNames = IntMap QName

+ Agda.Compiler.Backend: type DisambiguatedNames = IntMap DisambiguatedName

- Agda.Compiler.Backend: type InteractionPoints = Map InteractionId InteractionPoint

+ Agda.Compiler.Backend: type InteractionPoints = BiMap InteractionId InteractionPoint

- Agda.Compiler.Backend: typeError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => TypeError -> m a

+ Agda.Compiler.Backend: typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a

- Agda.Compiler.Backend: typeError_ :: (MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr

+ Agda.Compiler.Backend: typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr

- Agda.Compiler.Backend: underAbstraction :: (Subst t a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.Compiler.Backend: underAbstraction :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.Compiler.Backend: underAbstraction' :: (Subst t a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.Compiler.Backend: underAbstraction' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.Compiler.Backend: underAbstractionAbs :: (Subst t a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.Compiler.Backend: underAbstractionAbs :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.Compiler.Backend: underAbstractionAbs' :: (Subst t a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.Compiler.Backend: underAbstractionAbs' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.Compiler.Backend: underAbstraction_ :: (Subst t a, MonadAddContext m) => Abs a -> (a -> m b) -> m b

+ Agda.Compiler.Backend: underAbstraction_ :: (Subst a, MonadAddContext m) => Abs a -> (a -> m b) -> m b

- Agda.Compiler.Backend: updateContext :: MonadAddContext m => Substitution -> (Context -> Context) -> m a -> m a

+ Agda.Compiler.Backend: updateContext :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Substitution -> (Context -> Context) -> m a -> m a

- Agda.Compiler.Backend: verboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a

+ Agda.Compiler.Backend: verboseBracket :: (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> String -> m a -> m a

- Agda.Compiler.Backend: wakeConstraints :: MonadConstraint m => (ProblemConstraint -> m Bool) -> m ()

+ Agda.Compiler.Backend: wakeConstraints :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m ()

- Agda.Compiler.Backend: withFreshName :: MonadAddContext m => Range -> ArgName -> (Name -> m a) -> m a

+ Agda.Compiler.Backend: withFreshName :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Range -> ArgName -> (Name -> m a) -> m a

- Agda.Compiler.Backend: withSignature :: Signature -> TCM a -> TCM a

+ Agda.Compiler.Backend: withSignature :: (ReadTCState m, MonadTCState m) => Signature -> m a -> m a

- Agda.Compiler.Common: compileDir :: TCM FilePath

+ Agda.Compiler.Common: compileDir :: HasOptions m => m FilePath

- Agda.Compiler.Common: curDefs :: TCM Definitions

+ Agda.Compiler.Common: curDefs :: ReadTCState m => m Definitions

- Agda.Compiler.Common: curIF :: TCM Interface

+ Agda.Compiler.Common: curIF :: ReadTCState m => m Interface

- Agda.Compiler.Common: curMName :: TCM ModuleName

+ Agda.Compiler.Common: curMName :: ReadTCState m => m ModuleName

- Agda.Compiler.Common: doCompile :: forall r. Monoid r => IsMain -> Interface -> (IsMain -> Interface -> TCM r) -> TCM r

+ Agda.Compiler.Common: doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r

- Agda.Compiler.Common: inCompilerEnv :: Interface -> TCM a -> TCM a

+ Agda.Compiler.Common: inCompilerEnv :: CheckResult -> TCM a -> TCM a

- Agda.Compiler.Common: topLevelModuleName :: ModuleName -> TCM ModuleName

+ Agda.Compiler.Common: topLevelModuleName :: ReadTCState m => ModuleName -> m ModuleName

- Agda.Compiler.JS.Compiler: JSOptions :: Bool -> JSOptions

+ Agda.Compiler.JS.Compiler: JSOptions :: Bool -> Bool -> Bool -> Bool -> JSOptions

- Agda.Compiler.JS.Compiler: compileAlt :: TAlt -> TCM (MemberId, Exp)

+ Agda.Compiler.JS.Compiler: compileAlt :: EnvWithOpts -> TAlt -> TCM ((QName, MemberId), Exp)

- Agda.Compiler.JS.Compiler: compileTerm :: TTerm -> TCM Exp

+ Agda.Compiler.JS.Compiler: compileTerm :: EnvWithOpts -> TTerm -> TCM Exp

- Agda.Compiler.JS.Compiler: definition :: Maybe CoinductionKit -> (QName, Definition) -> TCM (Maybe Export)

+ Agda.Compiler.JS.Compiler: definition :: EnvWithOpts -> (QName, Definition) -> TCM (Maybe Export)

- Agda.Compiler.JS.Compiler: definition' :: Maybe CoinductionKit -> QName -> Definition -> Type -> [MemberId] -> TCM (Maybe Export)

+ Agda.Compiler.JS.Compiler: definition' :: EnvWithOpts -> QName -> Definition -> Type -> JSQName -> TCM (Maybe Export)

- Agda.Compiler.JS.Compiler: global :: QName -> TCM (Exp, [MemberId])

+ Agda.Compiler.JS.Compiler: global :: QName -> TCM (Exp, JSQName)

- Agda.Compiler.JS.Compiler: global' :: QName -> TCM (Exp, [MemberId])

+ Agda.Compiler.JS.Compiler: global' :: QName -> TCM (Exp, JSQName)

- Agda.Compiler.JS.Compiler: insertAfter :: Set [MemberId] -> Export -> [Export] -> [Export]

+ Agda.Compiler.JS.Compiler: insertAfter :: Set JSQName -> Export -> [Export] -> [Export]

- Agda.Compiler.JS.Compiler: jsBackend' :: Backend' JSOptions JSOptions JSModuleEnv () (Maybe Export)

+ Agda.Compiler.JS.Compiler: jsBackend' :: Backend' JSOptions JSOptions JSModuleEnv Module (Maybe Export)

- Agda.Compiler.JS.Compiler: jsPostCompile :: JSOptions -> IsMain -> a -> TCM ()

+ Agda.Compiler.JS.Compiler: jsPostCompile :: JSOptions -> IsMain -> Map ModuleName Module -> TCM ()

- Agda.Compiler.JS.Compiler: jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM ()

+ Agda.Compiler.JS.Compiler: jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM Module

- Agda.Compiler.JS.Compiler: jsPreModule :: JSOptions -> IsMain -> ModuleName -> FilePath -> TCM (Recompile JSModuleEnv ())

+ Agda.Compiler.JS.Compiler: jsPreModule :: JSOptions -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module)

- Agda.Compiler.JS.Compiler: reorder' :: Set [MemberId] -> [Export] -> [Export]

+ Agda.Compiler.JS.Compiler: reorder' :: Set JSQName -> [Export] -> [Export]

- Agda.Compiler.JS.Compiler: writeModule :: Module -> TCM ()

+ Agda.Compiler.JS.Compiler: writeModule :: Bool -> Module -> TCM ()

- Agda.Compiler.JS.Pretty: block :: Nat -> Int -> Exp -> String

+ Agda.Compiler.JS.Pretty: block :: (Nat, Bool) -> Exp -> Doc

- Agda.Compiler.JS.Pretty: exports :: Nat -> Int -> Set [MemberId] -> [Export] -> String

+ Agda.Compiler.JS.Pretty: exports :: (Nat, Bool) -> Set JSQName -> [Export] -> Doc

- Agda.Compiler.JS.Pretty: modname :: GlobalId -> String

+ Agda.Compiler.JS.Pretty: modname :: GlobalId -> Doc

- Agda.Compiler.JS.Pretty: pretties :: Pretties a => Nat -> Int -> a -> [String]

+ Agda.Compiler.JS.Pretty: pretties :: Pretties a => (Nat, Bool) -> a -> [Doc]

- Agda.Compiler.JS.Pretty: pretty :: Pretty a => Nat -> Int -> a -> String

+ Agda.Compiler.JS.Pretty: pretty :: Pretty a => (Nat, Bool) -> a -> Doc

- Agda.Compiler.JS.Pretty: unescapes :: String -> String

+ Agda.Compiler.JS.Pretty: unescapes :: String -> Doc

- Agda.Compiler.JS.Syntax: Export :: [MemberId] -> Exp -> Export

+ Agda.Compiler.JS.Syntax: Export :: JSQName -> Exp -> Export

- Agda.Compiler.JS.Syntax: Module :: GlobalId -> [Export] -> Maybe Exp -> Module

+ Agda.Compiler.JS.Syntax: Module :: GlobalId -> [GlobalId] -> [Export] -> Maybe Exp -> Module

- Agda.Compiler.JS.Syntax: String :: String -> Exp

+ Agda.Compiler.JS.Syntax: String :: Text -> Exp

- Agda.Compiler.JS.Syntax: [expName] :: Export -> [MemberId]

+ Agda.Compiler.JS.Syntax: [expName] :: Export -> JSQName

- Agda.Compiler.JS.Syntax: globals :: Globals a => a -> Set GlobalId

+ Agda.Compiler.JS.Syntax: globals :: (Globals a, a ~ t b, Foldable t, Globals b) => a -> Set GlobalId

- Agda.Compiler.JS.Syntax: uses :: Uses a => a -> Set [MemberId]

+ Agda.Compiler.JS.Syntax: uses :: (Uses a, a ~ t b, Foldable t, Uses b) => a -> Set JSQName

- Agda.Compiler.MAlonzo.Coerce: addCoercions :: TTerm -> TCM TTerm

+ Agda.Compiler.MAlonzo.Coerce: addCoercions :: HasConstInfo m => TTerm -> m TTerm

- Agda.Compiler.MAlonzo.Coerce: erasedArity :: QName -> TCM Nat

+ Agda.Compiler.MAlonzo.Coerce: erasedArity :: HasConstInfo m => QName -> m Nat

- Agda.Compiler.MAlonzo.Compiler: GHCOptions :: Bool -> Bool -> [String] -> GHCOptions

+ Agda.Compiler.MAlonzo.Compiler: GHCOptions :: Bool -> FilePath -> [String] -> FilePath -> GHCOptions

- Agda.Compiler.MAlonzo.Compiler: callGHC :: GHCOptions -> IsMain -> Map ModuleName IsMain -> TCM ()

+ Agda.Compiler.MAlonzo.Compiler: callGHC :: ReaderT GHCModule TCM ()

- Agda.Compiler.MAlonzo.Compiler: checkConstructorType :: QName -> HaskellCode -> TCM [Decl]

+ Agda.Compiler.MAlonzo.Compiler: checkConstructorType :: QName -> HaskellCode -> HsCompileM [Decl]

- Agda.Compiler.MAlonzo.Compiler: checkCover :: QName -> HaskellType -> Nat -> [QName] -> [HaskellCode] -> TCM [Decl]

+ Agda.Compiler.MAlonzo.Compiler: checkCover :: HasConstInfo m => QName -> HaskellType -> Nat -> [QName] -> [HaskellCode] -> m [Decl]

- Agda.Compiler.MAlonzo.Compiler: closedTerm :: TTerm -> TCM Exp

+ Agda.Compiler.MAlonzo.Compiler: closedTerm :: TTerm -> HsCompileM (Exp, UsesFloat)

- Agda.Compiler.MAlonzo.Compiler: compiledcondecl :: QName -> TCM Decl

+ Agda.Compiler.MAlonzo.Compiler: compiledcondecl :: QName -> HsCompileM Decl

- Agda.Compiler.MAlonzo.Compiler: condecl :: QName -> Induction -> TCM ConDecl

+ Agda.Compiler.MAlonzo.Compiler: condecl :: QName -> Induction -> HsCompileM ConDecl

- Agda.Compiler.MAlonzo.Compiler: constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> TCM [Decl]

+ Agda.Compiler.MAlonzo.Compiler: constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> HsCompileM [Decl]

- Agda.Compiler.MAlonzo.Compiler: copyRTEModules :: TCM ()

+ Agda.Compiler.MAlonzo.Compiler: copyRTEModules :: MonadGHCIO m => m ()

- Agda.Compiler.MAlonzo.Compiler: definition :: GHCModuleEnv -> IsMain -> Definition -> TCM [Decl]

+ Agda.Compiler.MAlonzo.Compiler: definition :: Definition -> HsCompileM (UsesFloat, [Decl], Maybe CheckedMainFunctionDef)

- Agda.Compiler.MAlonzo.Compiler: freshNames :: Int -> ([Name] -> CC a) -> CC a

+ Agda.Compiler.MAlonzo.Compiler: freshNames :: Monad m => Int -> ([Name] -> CCT m a) -> CCT m a

- Agda.Compiler.MAlonzo.Compiler: ghcBackend' :: Backend' GHCOptions GHCOptions GHCModuleEnv IsMain [Decl]

+ Agda.Compiler.MAlonzo.Compiler: ghcBackend' :: Backend' GHCFlags GHCCompileEnv GHCModuleEnv GHCModule GHCDefinition

- Agda.Compiler.MAlonzo.Compiler: ghcCommandLineFlags :: [OptDescr (Flag GHCOptions)]

+ Agda.Compiler.MAlonzo.Compiler: ghcCommandLineFlags :: [OptDescr (Flag GHCFlags)]

- Agda.Compiler.MAlonzo.Compiler: ghcCompileDef :: GHCOptions -> GHCModuleEnv -> IsMain -> Definition -> TCM [Decl]

+ Agda.Compiler.MAlonzo.Compiler: ghcCompileDef :: GHCCompileEnv -> GHCModuleEnv -> IsMain -> Definition -> TCM GHCDefinition

- Agda.Compiler.MAlonzo.Compiler: ghcPostCompile :: GHCOptions -> IsMain -> Map ModuleName IsMain -> TCM ()

+ Agda.Compiler.MAlonzo.Compiler: ghcPostCompile :: GHCCompileEnv -> IsMain -> Map ModuleName GHCModule -> TCM ()

- Agda.Compiler.MAlonzo.Compiler: ghcPostModule :: GHCOptions -> GHCModuleEnv -> IsMain -> ModuleName -> [[Decl]] -> TCM IsMain

+ Agda.Compiler.MAlonzo.Compiler: ghcPostModule :: GHCCompileEnv -> GHCModuleEnv -> IsMain -> ModuleName -> [GHCDefinition] -> TCM GHCModule

- Agda.Compiler.MAlonzo.Compiler: ghcPreCompile :: GHCOptions -> TCM GHCOptions

+ Agda.Compiler.MAlonzo.Compiler: ghcPreCompile :: GHCFlags -> TCM GHCCompileEnv

- Agda.Compiler.MAlonzo.Compiler: ghcPreModule :: GHCOptions -> IsMain -> ModuleName -> FilePath -> TCM (Recompile GHCModuleEnv IsMain)

+ Agda.Compiler.MAlonzo.Compiler: ghcPreModule :: GHCCompileEnv -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile GHCModuleEnv GHCModule)

- Agda.Compiler.MAlonzo.Compiler: imports :: TCM [ImportDecl]

+ Agda.Compiler.MAlonzo.Compiler: imports :: BuiltinThings PrimFun -> Set ModuleName -> [Definition] -> [ImportDecl]

- Agda.Compiler.MAlonzo.Compiler: intros :: Int -> ([Name] -> CC a) -> CC a

+ Agda.Compiler.MAlonzo.Compiler: intros :: Monad m => Int -> ([Name] -> CCT m a) -> CCT m a

- Agda.Compiler.MAlonzo.Compiler: litString :: String -> Exp

+ Agda.Compiler.MAlonzo.Compiler: litString :: Text -> Exp

- Agda.Compiler.MAlonzo.Compiler: literal :: Literal -> Exp

+ Agda.Compiler.MAlonzo.Compiler: literal :: forall m. Monad m => Literal -> CCT m Exp

- Agda.Compiler.MAlonzo.Compiler: type CC = ReaderT CCEnv TCM

+ Agda.Compiler.MAlonzo.Compiler: type CC = CCT TCM

- Agda.Compiler.MAlonzo.Compiler: writeModule :: Module -> TCM ()

+ Agda.Compiler.MAlonzo.Compiler: writeModule :: MonadGHCIO m => Module -> m ()

- Agda.Compiler.MAlonzo.HaskellTypes: haskellType :: QName -> TCM Type

+ Agda.Compiler.MAlonzo.HaskellTypes: haskellType :: QName -> HsCompileM Type

- Agda.Compiler.MAlonzo.HaskellTypes: hsTelApproximation :: Type -> TCM ([Type], Type)

+ Agda.Compiler.MAlonzo.HaskellTypes: hsTelApproximation :: Type -> HsCompileM ([Type], Type)

- Agda.Compiler.MAlonzo.HaskellTypes: hsTelApproximation' :: PolyApprox -> Type -> TCM ([Type], Type)

+ Agda.Compiler.MAlonzo.HaskellTypes: hsTelApproximation' :: PolyApprox -> Type -> HsCompileM ([Type], Type)

- Agda.Compiler.MAlonzo.Misc: bltQual :: String -> String -> TCM QName

+ Agda.Compiler.MAlonzo.Misc: bltQual :: String -> String -> HsCompileM QName

- Agda.Compiler.MAlonzo.Misc: conhqn :: QName -> TCM QName

+ Agda.Compiler.MAlonzo.Misc: conhqn :: QName -> HsCompileM QName

- Agda.Compiler.MAlonzo.Misc: curHsMod :: TCM ModuleName

+ Agda.Compiler.MAlonzo.Misc: curHsMod :: ReadHsModuleEnv m => m ModuleName

- Agda.Compiler.MAlonzo.Misc: rtmError :: String -> Exp

+ Agda.Compiler.MAlonzo.Misc: rtmError :: Text -> Exp

- Agda.Compiler.MAlonzo.Misc: tlmodOf :: ModuleName -> TCM ModuleName

+ Agda.Compiler.MAlonzo.Misc: tlmodOf :: ReadTCState m => ModuleName -> m ModuleName

- Agda.Compiler.MAlonzo.Misc: xhqn :: String -> QName -> TCM QName

+ Agda.Compiler.MAlonzo.Misc: xhqn :: String -> QName -> HsCompileM QName

- Agda.Compiler.MAlonzo.Misc: xqual :: QName -> Name -> TCM QName

+ Agda.Compiler.MAlonzo.Misc: xqual :: QName -> Name -> HsCompileM QName

- Agda.Compiler.MAlonzo.Pragmas: foreignHaskell :: TCM ([String], [String], [String])

+ Agda.Compiler.MAlonzo.Pragmas: foreignHaskell :: Interface -> ([String], [String], [String])

- Agda.Compiler.MAlonzo.Pragmas: parseHaskellPragma :: CompilerPragma -> TCM HaskellPragma

+ Agda.Compiler.MAlonzo.Pragmas: parseHaskellPragma :: (MonadTCError m, MonadTrace m) => CompilerPragma -> m HaskellPragma

- Agda.Compiler.MAlonzo.Pragmas: sanityCheckPragma :: Definition -> Maybe HaskellPragma -> TCM ()

+ Agda.Compiler.MAlonzo.Pragmas: sanityCheckPragma :: (HasBuiltins m, MonadTCError m, MonadReduce m) => Definition -> Maybe HaskellPragma -> m ()

- Agda.Compiler.MAlonzo.Primitives: bltQual' :: String -> String -> TCM String

+ Agda.Compiler.MAlonzo.Primitives: bltQual' :: String -> String -> HsCompileM String

- Agda.Compiler.MAlonzo.Primitives: checkTypeOfMain :: IsMain -> QName -> Definition -> TCM [Decl] -> TCM [Decl]

+ Agda.Compiler.MAlonzo.Primitives: checkTypeOfMain :: Definition -> HsCompileM (Maybe CheckedMainFunctionDef)

- Agda.Compiler.MAlonzo.Primitives: importsForPrim :: TCM [ModuleName]

+ Agda.Compiler.MAlonzo.Primitives: importsForPrim :: BuiltinThings PrimFun -> [Definition] -> [ModuleName]

- Agda.Compiler.MAlonzo.Primitives: noCheckCover :: QName -> TCM Bool

+ Agda.Compiler.MAlonzo.Primitives: noCheckCover :: (HasBuiltins m, MonadReduce m) => QName -> m Bool

- Agda.Compiler.MAlonzo.Primitives: primBody :: String -> TCM Exp

+ Agda.Compiler.MAlonzo.Primitives: primBody :: MonadTCError m => String -> m Exp

- Agda.Compiler.MAlonzo.Primitives: xForPrim :: [(String, TCM [a])] -> TCM [a]

+ Agda.Compiler.MAlonzo.Primitives: xForPrim :: Map String [a] -> BuiltinThings PrimFun -> [Definition] -> [a]

- Agda.Compiler.Treeless.Subst: tryStrengthen :: (HasFree a, Subst t a) => Int -> a -> Maybe a

+ Agda.Compiler.Treeless.Subst: tryStrengthen :: (HasFree a, Subst a) => Int -> a -> Maybe a

- Agda.Compiler.Treeless.Unused: stripUnusedArguments :: [Bool] -> TTerm -> TTerm

+ Agda.Compiler.Treeless.Unused: stripUnusedArguments :: [ArgUsage] -> TTerm -> TTerm

- Agda.Compiler.Treeless.Unused: usedArguments :: QName -> TTerm -> TCM [Bool]

+ Agda.Compiler.Treeless.Unused: usedArguments :: QName -> TTerm -> TCM [ArgUsage]

- Agda.ImpossibleTest: impossibleTest :: a

+ Agda.ImpossibleTest: impossibleTest :: (MonadDebug m, HasCallStack) => [String] -> m a

- Agda.Interaction.Base: Cmd_metas :: Interaction' range

+ Agda.Interaction.Base: Cmd_metas :: Rewrite -> Interaction' range

- Agda.Interaction.Base: CommandState :: [InteractionId] -> Maybe (AbsolutePath, ClockTime) -> CommandLineOptions -> !OldInteractionScopes -> !CommandQueue -> CommandState

+ Agda.Interaction.Base: CommandState :: [InteractionId] -> Maybe CurrentFile -> CommandLineOptions -> !OldInteractionScopes -> !CommandQueue -> CommandState

- Agda.Interaction.Base: FindInstanceOF :: b -> a -> [(a, a)] -> OutputConstraint a b

+ Agda.Interaction.Base: FindInstanceOF :: b -> a -> [(a, a, a)] -> OutputConstraint a b

- Agda.Interaction.Base: OutputForm :: Range -> [ProblemId] -> OutputConstraint a b -> OutputForm a b

+ Agda.Interaction.Base: OutputForm :: Range -> [ProblemId] -> Blocker -> OutputConstraint a b -> OutputForm a b

- Agda.Interaction.Base: PostponedCheckFunDef :: QName -> a -> OutputConstraint a b

+ Agda.Interaction.Base: PostponedCheckFunDef :: QName -> a -> TCErr -> OutputConstraint a b

- Agda.Interaction.Base: [theCurrentFile] :: CommandState -> Maybe (AbsolutePath, ClockTime)

+ Agda.Interaction.Base: [theCurrentFile] :: CommandState -> Maybe CurrentFile

- Agda.Interaction.BasicOps: evalInCurrent :: Expr -> TCM Expr

+ Agda.Interaction.BasicOps: evalInCurrent :: ComputeMode -> Expr -> TCM Expr

- Agda.Interaction.BasicOps: evalInMeta :: InteractionId -> Expr -> TCM Expr

+ Agda.Interaction.BasicOps: evalInMeta :: InteractionId -> ComputeMode -> Expr -> TCM Expr

- Agda.Interaction.BasicOps: getModuleContents :: Rewrite -> QName -> TCM ([Name], Telescope, [(Name, Type)])

+ Agda.Interaction.BasicOps: getModuleContents :: Rewrite -> Maybe QName -> TCM ([Name], Telescope, [(Name, Type)])

- Agda.Interaction.BasicOps: normalForm :: (Reduce t, Simplify t, Normalise t) => Rewrite -> t -> TCM t

+ Agda.Interaction.BasicOps: normalForm :: (Reduce t, Simplify t, Instantiate t, Normalise t) => Rewrite -> t -> TCM t

- Agda.Interaction.Highlighting.Generate: errorHighlighting :: TCErr -> TCM File

+ Agda.Interaction.Highlighting.Generate: errorHighlighting :: TCErr -> TCM HighlightingInfoBuilder

- Agda.Interaction.Highlighting.Generate: generateTokenInfo :: AbsolutePath -> TCM CompressedFile

+ Agda.Interaction.Highlighting.Generate: generateTokenInfo :: AbsolutePath -> TCM HighlightingInfo

- Agda.Interaction.Highlighting.Generate: generateTokenInfoFromSource :: AbsolutePath -> String -> TCM CompressedFile

+ Agda.Interaction.Highlighting.Generate: generateTokenInfoFromSource :: AbsolutePath -> String -> TCM HighlightingInfo

- Agda.Interaction.Highlighting.Generate: generateTokenInfoFromString :: Range -> String -> TCM CompressedFile

+ Agda.Interaction.Highlighting.Generate: generateTokenInfoFromString :: Range -> String -> TCM HighlightingInfo

- Agda.Interaction.Highlighting.Generate: highlightAsTypeChecked :: (MonadTCM tcm, ReadTCState tcm) => Range -> Range -> tcm a -> tcm a

+ Agda.Interaction.Highlighting.Generate: highlightAsTypeChecked :: MonadTrace m => Range -> Range -> m a -> m a

- Agda.Interaction.Highlighting.Generate: printHighlightingInfo :: (MonadTCM tcm, ReadTCState tcm) => RemoveTokenBasedHighlighting -> HighlightingInfo -> tcm ()

+ Agda.Interaction.Highlighting.Generate: printHighlightingInfo :: MonadTrace m => RemoveTokenBasedHighlighting -> HighlightingInfo -> m ()

- Agda.Interaction.Highlighting.Generate: warningHighlighting :: TCWarning -> File

+ Agda.Interaction.Highlighting.Generate: warningHighlighting :: TCWarning -> HighlightingInfoBuilder

- Agda.Interaction.Highlighting.Precise: Aspects :: Maybe Aspect -> Set OtherAspect -> Maybe String -> Maybe DefinitionSite -> !TokenBased -> Aspects

+ Agda.Interaction.Highlighting.Precise: Aspects :: Maybe Aspect -> Set OtherAspect -> String -> Maybe DefinitionSite -> !TokenBased -> Aspects

- Agda.Interaction.Highlighting.Precise: [note] :: Aspects -> Maybe String

+ Agda.Interaction.Highlighting.Precise: [note] :: Aspects -> String

- Agda.Interaction.Highlighting.Precise: several :: [Ranges] -> Aspects -> File

+ Agda.Interaction.Highlighting.Precise: several :: (IsBasicRangeMap a hl, Monoid hl) => [Ranges] -> a -> hl

- Agda.Interaction.Highlighting.Precise: singleton :: Ranges -> Aspects -> File

+ Agda.Interaction.Highlighting.Precise: singleton :: IsBasicRangeMap a m => Ranges -> a -> m

- Agda.Interaction.Highlighting.Precise: toMap :: File -> IntMap Aspects

+ Agda.Interaction.Highlighting.Precise: toMap :: IsBasicRangeMap a m => m -> IntMap a

- Agda.Interaction.Highlighting.Precise: type HighlightingInfo = CompressedFile

+ Agda.Interaction.Highlighting.Precise: type HighlightingInfo = RangeMap Aspects

- Agda.Interaction.Highlighting.Range: Range :: Int -> Range

+ Agda.Interaction.Highlighting.Range: Range :: !Int -> Range

- Agda.Interaction.Highlighting.Range: [from, to] :: Range -> Int

+ Agda.Interaction.Highlighting.Range: [from, to] :: Range -> !Int

- Agda.Interaction.Highlighting.Range: empty :: Range -> Bool

+ Agda.Interaction.Highlighting.Range: empty :: Null a => a

- Agda.Interaction.Imports: readInterface :: AbsolutePath -> TCM (Maybe Interface)

+ Agda.Interaction.Imports: readInterface :: InterfaceFile -> TCM (Maybe Interface)

- Agda.Interaction.Imports: typeCheckMain :: SourceFile -> Mode -> SourceInfo -> TCM (Interface, MaybeWarnings)

+ Agda.Interaction.Imports: typeCheckMain :: Mode -> Source -> TCM CheckResult

- Agda.Interaction.InteractionTop: cmd_load' :: FilePath -> [String] -> Bool -> Mode -> ((Interface, MaybeWarnings) -> CommandM ()) -> CommandM ()

+ Agda.Interaction.InteractionTop: cmd_load' :: FilePath -> [String] -> Bool -> Mode -> (CheckResult -> CommandM a) -> CommandM a

- Agda.Interaction.Library: LibWarning :: LibPositionInfo -> LibWarning' -> LibWarning

+ Agda.Interaction.Library: LibWarning :: Maybe LibPositionInfo -> LibWarning' -> LibWarning

- Agda.Interaction.Library: findProjectRoot :: FilePath -> IO (Maybe FilePath)

+ Agda.Interaction.Library: findProjectRoot :: FilePath -> LibM (Maybe FilePath)

- Agda.Interaction.Library: type LibM = ExceptT Doc (WriterT [LibWarning] IO)

+ Agda.Interaction.Library: type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO))

- Agda.Interaction.Library.Base: AgdaLibFile :: LibName -> FilePath -> [FilePath] -> [LibName] -> AgdaLibFile

+ Agda.Interaction.Library.Base: AgdaLibFile :: LibName -> FilePath -> [FilePath] -> [LibName] -> [String] -> AgdaLibFile

- Agda.Interaction.MakeCase: parseVariables :: QName -> Telescope -> InteractionId -> Range -> [String] -> TCM [(Int, NameInScope)]

+ Agda.Interaction.MakeCase: parseVariables :: QName -> Context -> [AsBinding] -> InteractionId -> Range -> [String] -> TCM [(Int, NameInScope)]

- Agda.Interaction.MakeCase: recheckAbstractClause :: Type -> Maybe Substitution -> SpineClause -> TCM Clause

+ Agda.Interaction.MakeCase: recheckAbstractClause :: Type -> Maybe Substitution -> SpineClause -> TCM (Clause, Context, [AsBinding])

- Agda.Interaction.Options: Options :: String -> Maybe FilePath -> [FilePath] -> [AbsolutePath] -> [LibName] -> Maybe FilePath -> Bool -> Bool -> Bool -> Maybe Help -> Bool -> Bool -> Bool -> Bool -> Maybe FilePath -> Bool -> Bool -> Bool -> HtmlHighlight -> Maybe FilePath -> FilePath -> FilePath -> Maybe FilePath -> Bool -> Bool -> Bool -> PragmaOptions -> Bool -> Maybe FilePath -> CommandLineOptions

+ Agda.Interaction.Options: Options :: String -> Maybe FilePath -> [FilePath] -> [AbsolutePath] -> [LibName] -> Maybe FilePath -> Bool -> Bool -> Map ExeName FilePath -> Bool -> Bool -> Maybe Help -> Bool -> Bool -> Bool -> Bool -> Maybe FilePath -> Bool -> Bool -> Bool -> Bool -> PragmaOptions -> Bool -> CommandLineOptions

- Agda.Interaction.Options: PragmaOptions :: Bool -> Bool -> Bool -> Verbosity -> Bool -> Bool -> Bool -> Bool -> Bool -> CutOff -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> WithDefault 'True -> WithDefault 'True -> Bool -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> WarningMode -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> PragmaOptions

+ Agda.Interaction.Options: PragmaOptions :: Bool -> Bool -> UnicodeOrAscii -> Verbosity -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> CutOff -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> WithDefault 'False -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Int -> Bool -> Bool -> Bool -> WarningMode -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe ConfluenceCheck -> Bool -> Bool -> Bool -> Bool -> PragmaOptions

- Agda.Interaction.Options: [optConfluenceCheck] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optConfluenceCheck] :: PragmaOptions -> Maybe ConfluenceCheck

- Agda.Interaction.Options: [optGuardedness] :: PragmaOptions -> WithDefault 'True

+ Agda.Interaction.Options: [optGuardedness] :: PragmaOptions -> WithDefault 'False

- Agda.Interaction.Options: [optSizedTypes] :: PragmaOptions -> WithDefault 'True

+ Agda.Interaction.Options: [optSizedTypes] :: PragmaOptions -> WithDefault 'False

- Agda.Interaction.Options: [optUseUnicode] :: PragmaOptions -> Bool

+ Agda.Interaction.Options: [optUseUnicode] :: PragmaOptions -> UnicodeOrAscii

- Agda.Interaction.Options: runOptM :: OptM a -> IO (Either String a)

+ Agda.Interaction.Options: runOptM :: Monad m => OptM opts -> m (Either String opts)

- Agda.Interaction.Options: type OptM = ExceptT String IO

+ Agda.Interaction.Options: type OptM = Except String

- Agda.Interaction.Options: unsafePragmaOptions :: PragmaOptions -> [String]

+ Agda.Interaction.Options: unsafePragmaOptions :: CommandLineOptions -> PragmaOptions -> [String]

- Agda.Interaction.Options.Lenses: isBuiltinModule :: FilePath -> TCM Bool

+ Agda.Interaction.Options.Lenses: isBuiltinModule :: MonadIO m => FilePath -> m Bool

- Agda.Interaction.Options.Lenses: isBuiltinModuleWithSafePostulates :: FilePath -> TCM Bool

+ Agda.Interaction.Options.Lenses: isBuiltinModuleWithSafePostulates :: MonadIO m => FilePath -> m Bool

- Agda.Interaction.Options.Lenses: modifyAbsoluteIncludePaths :: ([AbsolutePath] -> [AbsolutePath]) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifyAbsoluteIncludePaths :: MonadTCState m => ([AbsolutePath] -> [AbsolutePath]) -> m ()

- Agda.Interaction.Options.Lenses: modifyCommandLineOptions :: (CommandLineOptions -> CommandLineOptions) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifyCommandLineOptions :: MonadTCState m => (CommandLineOptions -> CommandLineOptions) -> m ()

- Agda.Interaction.Options.Lenses: modifyIncludePaths :: ([FilePath] -> [FilePath]) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifyIncludePaths :: MonadTCState m => ([FilePath] -> [FilePath]) -> m ()

- Agda.Interaction.Options.Lenses: modifyPersistentVerbosity :: (PersistentVerbosity -> PersistentVerbosity) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifyPersistentVerbosity :: MonadTCState m => (PersistentVerbosity -> PersistentVerbosity) -> m ()

- Agda.Interaction.Options.Lenses: modifyPragmaOptions :: (PragmaOptions -> PragmaOptions) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifyPragmaOptions :: MonadTCState m => (PragmaOptions -> PragmaOptions) -> m ()

- Agda.Interaction.Options.Lenses: modifySafeMode :: (SafeMode -> SafeMode) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifySafeMode :: MonadTCState m => (SafeMode -> SafeMode) -> m ()

- Agda.Interaction.Options.Lenses: modifyVerbosity :: (Verbosity -> Verbosity) -> TCM ()

+ Agda.Interaction.Options.Lenses: modifyVerbosity :: MonadTCState m => (Verbosity -> Verbosity) -> m ()

- Agda.Interaction.Options.Lenses: putAbsoluteIncludePaths :: [AbsolutePath] -> TCM ()

+ Agda.Interaction.Options.Lenses: putAbsoluteIncludePaths :: MonadTCState m => [AbsolutePath] -> m ()

- Agda.Interaction.Options.Lenses: putIncludePaths :: [FilePath] -> TCM ()

+ Agda.Interaction.Options.Lenses: putIncludePaths :: MonadTCState m => [FilePath] -> m ()

- Agda.Interaction.Options.Lenses: putPersistentVerbosity :: PersistentVerbosity -> TCM ()

+ Agda.Interaction.Options.Lenses: putPersistentVerbosity :: MonadTCState m => PersistentVerbosity -> m ()

- Agda.Interaction.Options.Lenses: putSafeMode :: SafeMode -> TCM ()

+ Agda.Interaction.Options.Lenses: putSafeMode :: MonadTCState m => SafeMode -> m ()

- Agda.Interaction.Options.Lenses: putVerbosity :: Verbosity -> TCM ()

+ Agda.Interaction.Options.Lenses: putVerbosity :: MonadTCState m => Verbosity -> m ()

- Agda.Interaction.Options.Warnings: warningModeUpdate :: String -> Maybe (WarningMode -> WarningMode)

+ Agda.Interaction.Options.Warnings: warningModeUpdate :: String -> Either WarningModeError WarningModeUpdate

- Agda.Interaction.Response: Status :: Bool -> Bool -> Status

+ Agda.Interaction.Response: Status :: Bool -> Bool -> Bool -> Status

- Agda.Main: runAgdaWithOptions :: [Backend] -> TCM () -> (TCM (Maybe Interface) -> TCM a) -> String -> CommandLineOptions -> TCM (Maybe a)

+ Agda.Main: runAgdaWithOptions :: Interactor a -> String -> CommandLineOptions -> TCM a

- Agda.Syntax.Abstract: Axiom :: Axiom -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> Declaration

+ Agda.Syntax.Abstract: Axiom :: KindOfName -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> Declaration

- Agda.Syntax.Abstract: BuiltinNoDefPragma :: RString -> QName -> Pragma

+ Agda.Syntax.Abstract: BuiltinNoDefPragma :: RString -> KindOfName -> QName -> Pragma

- Agda.Syntax.Abstract: ExtendedLam :: ExprInfo -> DefInfo -> QName -> [Clause] -> Expr

+ Agda.Syntax.Abstract: ExtendedLam :: ExprInfo -> DefInfo -> Erased -> QName -> List1 Clause -> Expr

- Agda.Syntax.Abstract: LHSWith :: LHSCore' e -> [Pattern' e] -> [NamedArg (Pattern' e)] -> LHSCore' e

+ Agda.Syntax.Abstract: LHSWith :: LHSCore' e -> [Arg (Pattern' e)] -> [NamedArg (Pattern' e)] -> LHSCore' e

- Agda.Syntax.Abstract: Let :: ExprInfo -> [LetBinding] -> Expr -> Expr

+ Agda.Syntax.Abstract: Let :: ExprInfo -> List1 LetBinding -> Expr -> Expr

- Agda.Syntax.Abstract: Lit :: Literal -> Expr

+ Agda.Syntax.Abstract: Lit :: ExprInfo -> Literal -> Expr

- Agda.Syntax.Abstract: LitP :: Literal -> Pattern' e

+ Agda.Syntax.Abstract: LitP :: PatInfo -> Literal -> Pattern' e

- Agda.Syntax.Abstract: PatternSynDef :: QName -> [Arg Name] -> Pattern' Void -> Declaration

+ Agda.Syntax.Abstract: PatternSynDef :: QName -> [Arg BindName] -> Pattern' Void -> Declaration

- Agda.Syntax.Abstract: Pi :: ExprInfo -> Telescope -> Expr -> Expr

+ Agda.Syntax.Abstract: Pi :: ExprInfo -> Telescope1 -> Expr -> Expr

- Agda.Syntax.Abstract: Primitive :: DefInfo -> QName -> Expr -> Declaration

+ Agda.Syntax.Abstract: Primitive :: DefInfo -> QName -> Arg Expr -> Declaration

- Agda.Syntax.Abstract: RecDef :: DefInfo -> QName -> UniverseCheck -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe QName -> DataDefParams -> Expr -> [Declaration] -> Declaration

+ Agda.Syntax.Abstract: RecDef :: DefInfo -> QName -> UniverseCheck -> RecordDirectives -> DataDefParams -> Expr -> [Declaration] -> Declaration

- Agda.Syntax.Abstract: Section :: ModuleInfo -> ModuleName -> GeneralizeTelescope -> [Declaration] -> Declaration

+ Agda.Syntax.Abstract: Section :: Range -> ModuleName -> GeneralizeTelescope -> [Declaration] -> Declaration

- Agda.Syntax.Abstract: TBind :: Range -> TacticAttr -> [NamedArg Binder] -> Expr -> TypedBinding

+ Agda.Syntax.Abstract: TBind :: Range -> TacticAttr -> List1 (NamedArg Binder) -> Expr -> TypedBinding

- Agda.Syntax.Abstract: TLet :: Range -> [LetBinding] -> TypedBinding

+ Agda.Syntax.Abstract: TLet :: Range -> List1 LetBinding -> TypedBinding

- Agda.Syntax.Abstract: WhereDecls :: Maybe ModuleName -> [Declaration] -> WhereDeclarations

+ Agda.Syntax.Abstract: WhereDecls :: Maybe ModuleName -> Maybe Declaration -> WhereDeclarations

- Agda.Syntax.Abstract: WithRHS :: QName -> [WithHiding Expr] -> [Clause] -> RHS

+ Agda.Syntax.Abstract: WithRHS :: QName -> [WithExpr] -> [Clause] -> RHS

- Agda.Syntax.Abstract: [lhsWithPatterns] :: LHSCore' e -> [Pattern' e]

+ Agda.Syntax.Abstract: [lhsWithPatterns] :: LHSCore' e -> [Arg (Pattern' e)]

- Agda.Syntax.Abstract: [whereDecls] :: WhereDeclarations -> [Declaration]

+ Agda.Syntax.Abstract: [whereDecls] :: WhereDeclarations -> Maybe Declaration

- Agda.Syntax.Abstract: mkTBind :: Range -> [NamedArg Binder] -> Expr -> TypedBinding

+ Agda.Syntax.Abstract: mkTBind :: Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding

- Agda.Syntax.Abstract: substExpr :: SubstExpr a => [(Name, Expr)] -> a -> a

+ Agda.Syntax.Abstract: substExpr :: (SubstExpr a, Functor t, SubstExpr b, t b ~ a) => [(Name, Expr)] -> a -> a

- Agda.Syntax.Abstract: type HoleContent = HoleContent' () Pattern Expr

+ Agda.Syntax.Abstract: type HoleContent = HoleContent' () BindName Pattern Expr

- Agda.Syntax.Abstract: type Ren a = [(a, a)]

+ Agda.Syntax.Abstract: type Ren a = Map a (List1 a)

- Agda.Syntax.Abstract: type RewriteEqn = RewriteEqn' QName Pattern Expr

+ Agda.Syntax.Abstract: type RewriteEqn = RewriteEqn' QName BindName Pattern Expr

- Agda.Syntax.Abstract.Name: AmbQ :: NonEmpty QName -> AmbiguousQName

+ Agda.Syntax.Abstract.Name: AmbQ :: List1 QName -> AmbiguousQName

- Agda.Syntax.Abstract.Name: Name :: !NameId -> Name -> Range -> Fixity' -> Bool -> Name

+ Agda.Syntax.Abstract.Name: Name :: !NameId -> Name -> Name -> Range -> Fixity' -> Bool -> Name

- Agda.Syntax.Abstract.Name: [unAmbQ] :: AmbiguousQName -> NonEmpty QName

+ Agda.Syntax.Abstract.Name: [unAmbQ] :: AmbiguousQName -> List1 QName

- Agda.Syntax.Abstract.Name: nextName :: Name -> Name

+ Agda.Syntax.Abstract.Name: nextName :: FreshNameMode -> Name -> Name

- Agda.Syntax.Abstract.Name: qnameFromList :: [Name] -> QName

+ Agda.Syntax.Abstract.Name: qnameFromList :: List1 Name -> QName

- Agda.Syntax.Abstract.Name: qnameToList :: QName -> [Name]

+ Agda.Syntax.Abstract.Name: qnameToList :: QName -> List1 Name

- Agda.Syntax.Abstract.Name: withRangesOf :: ModuleName -> [Name] -> ModuleName

+ Agda.Syntax.Abstract.Name: withRangesOf :: ModuleName -> List1 Name -> ModuleName

- Agda.Syntax.Abstract.Pattern: checkPatternLinearity :: (Monad m, APatternLike a p) => p -> ([Name] -> m ()) -> m ()

+ Agda.Syntax.Abstract.Pattern: checkPatternLinearity :: (Monad m, APatternLike p) => p -> ([Name] -> m ()) -> m ()

- Agda.Syntax.Abstract.Pattern: class APatternLike a p | p -> a

+ Agda.Syntax.Abstract.Pattern: class APatternLike p where {

- Agda.Syntax.Abstract.Pattern: containsAPattern :: APatternLike a p => (Pattern' a -> Bool) -> p -> Bool

+ Agda.Syntax.Abstract.Pattern: containsAPattern :: APatternLike p => (Pattern' (ADotT p) -> Bool) -> p -> Bool

- Agda.Syntax.Abstract.Pattern: containsAbsurdPattern :: APatternLike a p => p -> Bool

+ Agda.Syntax.Abstract.Pattern: containsAbsurdPattern :: APatternLike p => p -> Bool

- Agda.Syntax.Abstract.Pattern: containsAsPattern :: APatternLike a p => p -> Bool

+ Agda.Syntax.Abstract.Pattern: containsAsPattern :: APatternLike p => p -> Bool

- Agda.Syntax.Abstract.Pattern: foldAPattern :: (APatternLike a p, Monoid m) => (Pattern' a -> m) -> p -> m

+ Agda.Syntax.Abstract.Pattern: foldAPattern :: (APatternLike p, Monoid m) => (Pattern' (ADotT p) -> m) -> p -> m

- Agda.Syntax.Abstract.Pattern: foldrAPattern :: (APatternLike a p, Monoid m, Foldable f, APatternLike a b, f b ~ p) => (Pattern' a -> m -> m) -> p -> m

+ Agda.Syntax.Abstract.Pattern: foldrAPattern :: (APatternLike p, Monoid m, Foldable f, APatternLike b, ADotT p ~ ADotT b, f b ~ p) => (Pattern' (ADotT p) -> m -> m) -> p -> m

- Agda.Syntax.Abstract.Pattern: lhsCoreWith :: LHSCore' e -> [Pattern' e] -> LHSCore' e

+ Agda.Syntax.Abstract.Pattern: lhsCoreWith :: LHSCore' e -> [Arg (Pattern' e)] -> LHSCore' e

- Agda.Syntax.Abstract.Pattern: mapAPattern :: APatternLike a p => (Pattern' a -> Pattern' a) -> p -> p

+ Agda.Syntax.Abstract.Pattern: mapAPattern :: APatternLike p => (Pattern' (ADotT p) -> Pattern' (ADotT p)) -> p -> p

- Agda.Syntax.Abstract.Pattern: patternVars :: forall a p. APatternLike a p => p -> [Name]

+ Agda.Syntax.Abstract.Pattern: patternVars :: APatternLike p => p -> [Name]

- Agda.Syntax.Abstract.Pattern: postTraverseAPatternM :: (APatternLike a b, Monad m) => (Pattern' a -> m (Pattern' a)) -> b -> m b

+ Agda.Syntax.Abstract.Pattern: postTraverseAPatternM :: (APatternLike p, Monad m) => (Pattern' (ADotT p) -> m (Pattern' (ADotT p))) -> p -> m p

- Agda.Syntax.Abstract.Pattern: preTraverseAPatternM :: (APatternLike a b, Monad m) => (Pattern' a -> m (Pattern' a)) -> b -> m b

+ Agda.Syntax.Abstract.Pattern: preTraverseAPatternM :: (APatternLike p, Monad m) => (Pattern' (ADotT p) -> m (Pattern' (ADotT p))) -> p -> m p

- Agda.Syntax.Abstract.Pattern: traverseAPatternM :: (APatternLike a p, Traversable f, APatternLike a q, f q ~ p, Monad m) => (Pattern' a -> m (Pattern' a)) -> (Pattern' a -> m (Pattern' a)) -> p -> m p

+ Agda.Syntax.Abstract.Pattern: traverseAPatternM :: (APatternLike p, Traversable f, APatternLike q, ADotT p ~ ADotT q, f q ~ p, Monad m) => (Pattern' (ADotT p) -> m (Pattern' (ADotT p))) -> (Pattern' (ADotT p) -> m (Pattern' (ADotT p))) -> p -> m p

- Agda.Syntax.Abstract.PatternSynonyms: mergePatternSynDefs :: NonEmpty PatternSynDefn -> Maybe PatternSynDefn

+ Agda.Syntax.Abstract.PatternSynonyms: mergePatternSynDefs :: List1 PatternSynDefn -> Maybe PatternSynDefn

- Agda.Syntax.Abstract.Pretty: prettyA :: (Pretty c, ToConcrete a c, MonadAbsToCon m) => a -> m Doc

+ Agda.Syntax.Abstract.Pretty: prettyA :: (ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc

- Agda.Syntax.Abstract.Pretty: prettyATop :: (Pretty c, ToConcrete a c, MonadAbsToCon m) => a -> m Doc

+ Agda.Syntax.Abstract.Pretty: prettyATop :: (ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc

- Agda.Syntax.Abstract.Pretty: prettyAs :: (Pretty c, ToConcrete a [c], MonadAbsToCon m) => a -> m Doc

+ Agda.Syntax.Abstract.Pretty: prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], Pretty ce, MonadAbsToCon m) => a -> m Doc

- Agda.Syntax.Abstract.Pretty: showA :: (Show c, ToConcrete a c, MonadAbsToCon m) => a -> m String

+ Agda.Syntax.Abstract.Pretty: showA :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String

- Agda.Syntax.Abstract.Pretty: showATop :: (Show c, ToConcrete a c, MonadAbsToCon m) => a -> m String

+ Agda.Syntax.Abstract.Pretty: showATop :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String

- Agda.Syntax.Abstract.Views: asView :: Pattern -> ([Name], Pattern)

+ Agda.Syntax.Abstract.Views: asView :: Pattern -> ([Name], [Expr], Pattern)

- Agda.Syntax.Abstract.Views: foldExpr :: (ExprLike a, Monoid m) => (Expr -> m) -> a -> m

+ Agda.Syntax.Abstract.Views: foldExpr :: ExprLike a => FoldExprFn m a

- Agda.Syntax.Abstract.Views: traverseExpr :: (ExprLike a, Applicative m, Monad m) => (Expr -> m Expr) -> a -> m a

+ Agda.Syntax.Abstract.Views: traverseExpr :: ExprLike a => TraverseExprFn m a

- Agda.Syntax.Common: ArgInfo :: Hiding -> Modality -> Origin -> FreeVariables -> ArgInfo

+ Agda.Syntax.Common: ArgInfo :: Hiding -> Modality -> Origin -> FreeVariables -> Annotation -> ArgInfo

- Agda.Syntax.Common: ImportDirective :: Range -> Using' n m -> [ImportedName' n m] -> [Renaming' n m] -> Maybe Range -> ImportDirective' n m

+ Agda.Syntax.Common: ImportDirective :: Range -> Using' n m -> HidingDirective' n m -> RenamingDirective' n m -> Maybe Range -> ImportDirective' n m

- Agda.Syntax.Common: Invert :: qn -> [(p, e)] -> RewriteEqn' qn p e

+ Agda.Syntax.Common: Invert :: qn -> List1 (Named nm (p, e)) -> RewriteEqn' qn nm p e

- Agda.Syntax.Common: NameId :: {-# UNPACK #-} !Word64 -> {-# UNPACK #-} !Word64 -> NameId

+ Agda.Syntax.Common: NameId :: {-# UNPACK #-} !Word64 -> {-# UNPACK #-} !ModuleNameHash -> NameId

- Agda.Syntax.Common: NoEta :: HasEta

+ Agda.Syntax.Common: NoEta :: a -> HasEta' a

- Agda.Syntax.Common: Rewrite :: [(qn, e)] -> RewriteEqn' qn p e

+ Agda.Syntax.Common: Rewrite :: List1 (qn, e) -> RewriteEqn' qn nm p e

- Agda.Syntax.Common: YesEta :: HasEta

+ Agda.Syntax.Common: YesEta :: HasEta' a

- Agda.Syntax.Common: [hiding] :: ImportDirective' n m -> [ImportedName' n m]

+ Agda.Syntax.Common: [hiding] :: ImportDirective' n m -> HidingDirective' n m

- Agda.Syntax.Common: [impRenaming] :: ImportDirective' n m -> [Renaming' n m]

+ Agda.Syntax.Common: [impRenaming] :: ImportDirective' n m -> RenamingDirective' n m

- Agda.Syntax.Common: bareNameOf :: LensNamed NamedName a => a -> Maybe ArgName

+ Agda.Syntax.Common: bareNameOf :: (LensNamed a, NameOf a ~ NamedName) => a -> Maybe ArgName

- Agda.Syntax.Common: bareNameWithDefault :: LensNamed NamedName a => ArgName -> a -> ArgName

+ Agda.Syntax.Common: bareNameWithDefault :: (LensNamed a, NameOf a ~ NamedName) => ArgName -> a -> ArgName

- Agda.Syntax.Common: class LensNamed name a | a -> name

+ Agda.Syntax.Common: class LensNamed a where {

- Agda.Syntax.Common: data RewriteEqn' qn p e

+ Agda.Syntax.Common: data RewriteEqn' qn nm p e

- Agda.Syntax.Common: fittingNamedArg :: (LensNamed NamedName arg, LensHiding arg, LensNamed NamedName dom, LensHiding dom) => arg -> dom -> Maybe Bool

+ Agda.Syntax.Common: fittingNamedArg :: (LensNamed arg, NameOf arg ~ NamedName, LensHiding arg, LensNamed dom, NameOf dom ~ NamedName, LensHiding dom) => arg -> dom -> Maybe Bool

- Agda.Syntax.Common: getNameOf :: LensNamed name a => a -> Maybe name

+ Agda.Syntax.Common: getNameOf :: LensNamed a => a -> Maybe (NameOf a)

- Agda.Syntax.Common: lensNamed :: (LensNamed name a, Decoration f, LensNamed name b, f b ~ a) => Lens' (Maybe name) a

+ Agda.Syntax.Common: lensNamed :: (LensNamed a, Decoration f, LensNamed b, NameOf b ~ NameOf a, f b ~ a) => Lens' (Maybe (NameOf a)) a

- Agda.Syntax.Common: mapNameOf :: LensNamed name a => (Maybe name -> Maybe name) -> a -> a

+ Agda.Syntax.Common: mapNameOf :: LensNamed a => (Maybe (NameOf a) -> Maybe (NameOf a)) -> a -> a

- Agda.Syntax.Common: namedSame :: (LensNamed NamedName a, LensNamed NamedName b) => a -> b -> Bool

+ Agda.Syntax.Common: namedSame :: (LensNamed a, LensNamed b, NameOf a ~ NamedName, NameOf b ~ NamedName) => a -> b -> Bool

- Agda.Syntax.Common: setNameOf :: LensNamed name a => Maybe name -> a -> a

+ Agda.Syntax.Common: setNameOf :: LensNamed a => Maybe (NameOf a) -> a -> a

- Agda.Syntax.Concrete: AnyWhere :: decls -> WhereClause' decls

+ Agda.Syntax.Concrete: AnyWhere :: Range -> decls -> WhereClause' decls

- Agda.Syntax.Concrete: DoBlock :: Range -> [DoStmt] -> Expr

+ Agda.Syntax.Concrete: DoBlock :: Range -> List1 DoStmt -> Expr

- Agda.Syntax.Concrete: DoLet :: Range -> [Declaration] -> DoStmt

+ Agda.Syntax.Concrete: DoLet :: Range -> List1 Declaration -> DoStmt

- Agda.Syntax.Concrete: EllipsisP :: Range -> Pattern

+ Agda.Syntax.Concrete: EllipsisP :: Range -> Maybe Pattern -> Pattern

- Agda.Syntax.Concrete: ExtendedLam :: Range -> [LamClause] -> Expr

+ Agda.Syntax.Concrete: ExtendedLam :: Range -> Erased -> List1 LamClause -> Expr

- Agda.Syntax.Concrete: HoleContentExpr :: e -> HoleContent' qn p e

+ Agda.Syntax.Concrete: HoleContentExpr :: e -> HoleContent' qn nm p e

- Agda.Syntax.Concrete: HoleContentRewrite :: [RewriteEqn' qn p e] -> HoleContent' qn p e

+ Agda.Syntax.Concrete: HoleContentRewrite :: [RewriteEqn' qn nm p e] -> HoleContent' qn nm p e

- Agda.Syntax.Concrete: ImpossiblePragma :: Range -> Pragma

+ Agda.Syntax.Concrete: ImpossiblePragma :: Range -> [String] -> Pragma

- Agda.Syntax.Concrete: Infix :: Fixity -> [Name] -> Declaration

+ Agda.Syntax.Concrete: Infix :: Fixity -> List1 Name -> Declaration

- Agda.Syntax.Concrete: LHS :: Pattern -> [RewriteEqn] -> [WithHiding WithExpr] -> ExpandedEllipsis -> LHS

+ Agda.Syntax.Concrete: LHS :: Pattern -> [RewriteEqn] -> [WithExpr] -> LHS

- Agda.Syntax.Concrete: Lam :: Range -> [LamBinding] -> Expr -> Expr

+ Agda.Syntax.Concrete: Lam :: Range -> List1 LamBinding -> Expr -> Expr

- Agda.Syntax.Concrete: LamClause :: LHS -> RHS -> WhereClause -> Bool -> LamClause

+ Agda.Syntax.Concrete: LamClause :: [Pattern] -> RHS -> Bool -> LamClause

- Agda.Syntax.Concrete: Let :: Range -> [Declaration] -> Maybe Expr -> Expr

+ Agda.Syntax.Concrete: Let :: Range -> List1 Declaration -> Maybe Expr -> Expr

- Agda.Syntax.Concrete: Lit :: Literal -> Expr

+ Agda.Syntax.Concrete: Lit :: Range -> Literal -> Expr

- Agda.Syntax.Concrete: LitP :: Literal -> Pattern

+ Agda.Syntax.Concrete: LitP :: Range -> Literal -> Pattern

- Agda.Syntax.Concrete: OpApp :: Range -> QName -> Set Name -> [NamedArg (MaybePlaceholder (OpApp Expr))] -> Expr

+ Agda.Syntax.Concrete: OpApp :: Range -> QName -> Set Name -> OpAppArgs -> Expr

- Agda.Syntax.Concrete: Pi :: Telescope -> Expr -> Expr

+ Agda.Syntax.Concrete: Pi :: Telescope1 -> Expr -> Expr

- Agda.Syntax.Concrete: RawApp :: Range -> [Expr] -> Expr

+ Agda.Syntax.Concrete: RawApp :: Range -> List2 Expr -> Expr

- Agda.Syntax.Concrete: RawAppP :: Range -> [Pattern] -> Pattern

+ Agda.Syntax.Concrete: RawAppP :: Range -> List2 Pattern -> Pattern

- Agda.Syntax.Concrete: Record :: Range -> Name -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe (Name, IsInstance) -> [LamBinding] -> Expr -> [Declaration] -> Declaration

+ Agda.Syntax.Concrete: Record :: Range -> Name -> RecordDirectives -> [LamBinding] -> Expr -> [Declaration] -> Declaration

- Agda.Syntax.Concrete: RecordDef :: Range -> Name -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe (Name, IsInstance) -> [LamBinding] -> [Declaration] -> Declaration

+ Agda.Syntax.Concrete: RecordDef :: Range -> Name -> RecordDirectives -> [LamBinding] -> [Declaration] -> Declaration

- Agda.Syntax.Concrete: SomeWhere :: Name -> Access -> decls -> WhereClause' decls

+ Agda.Syntax.Concrete: SomeWhere :: Range -> Name -> Access -> decls -> WhereClause' decls

- Agda.Syntax.Concrete: SyntaxBindingLambda :: Range -> [LamBinding] -> e -> OpApp e

+ Agda.Syntax.Concrete: SyntaxBindingLambda :: Range -> List1 LamBinding -> e -> OpApp e

- Agda.Syntax.Concrete: TBind :: Range -> [NamedArg Binder] -> e -> TypedBinding' e

+ Agda.Syntax.Concrete: TBind :: Range -> List1 (NamedArg Binder) -> e -> TypedBinding' e

- Agda.Syntax.Concrete: TLet :: Range -> [Declaration] -> TypedBinding' e

+ Agda.Syntax.Concrete: TLet :: Range -> List1 Declaration -> TypedBinding' e

- Agda.Syntax.Concrete: WarningOnImport :: Range -> String -> Pragma

+ Agda.Syntax.Concrete: WarningOnImport :: Range -> Text -> Pragma

- Agda.Syntax.Concrete: WarningOnUsage :: Range -> QName -> String -> Pragma

+ Agda.Syntax.Concrete: WarningOnUsage :: Range -> QName -> Text -> Pragma

- Agda.Syntax.Concrete: [lamLHS] :: LamClause -> LHS

+ Agda.Syntax.Concrete: [lamLHS] :: LamClause -> [Pattern]

- Agda.Syntax.Concrete: [lhsWithExpr] :: LHS -> [WithHiding WithExpr]

+ Agda.Syntax.Concrete: [lhsWithExpr] :: LHS -> [WithExpr]

- Agda.Syntax.Concrete: data HoleContent' qn p e

+ Agda.Syntax.Concrete: data HoleContent' qn nm p e

- Agda.Syntax.Concrete: type HoleContent = HoleContent' () Pattern Expr

+ Agda.Syntax.Concrete: type HoleContent = HoleContent' () Name Pattern Expr

- Agda.Syntax.Concrete: type RewriteEqn = RewriteEqn' () Pattern Expr

+ Agda.Syntax.Concrete: type RewriteEqn = RewriteEqn' () Name Pattern Expr

- Agda.Syntax.Concrete: type WithExpr = Expr

+ Agda.Syntax.Concrete: type WithExpr = Named Name (Arg Expr)

- Agda.Syntax.Concrete.Attribute: type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a)

+ Agda.Syntax.Concrete.Attribute: type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensLock a)

- Agda.Syntax.Concrete.Definitions: EmptyAbstract :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyAbstract :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyField :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyField :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyGeneralize :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyGeneralize :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyInstance :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyInstance :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyMacro :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyMacro :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyMutual :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyMutual :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyPostulate :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyPostulate :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyPrimitive :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyPrimitive :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: EmptyPrivate :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: EmptyPrivate :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: InvalidCatchallPragma :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: InvalidCatchallPragma :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: InvalidCoverageCheckPragma :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: InvalidCoverageCheckPragma :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: InvalidNoPositivityCheckPragma :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: InvalidNoPositivityCheckPragma :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: InvalidNoUniverseCheckPragma :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: InvalidNoUniverseCheckPragma :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: InvalidTerminationCheckPragma :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: InvalidTerminationCheckPragma :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: MissingDefinitions :: [(Name, Range)] -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: MissingDefinitions :: [(Name, Range)] -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe (Name, IsInstance) -> [LamBinding] -> [Declaration] -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions: NiceRecDef :: Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> RecordDirectives -> [LamBinding] -> [Declaration] -> NiceDeclaration

- Agda.Syntax.Concrete.Definitions: NotAllowedInMutual :: Range -> String -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: NotAllowedInMutual :: Range -> String -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: OpenPublicAbstract :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: OpenPublicAbstract :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: OpenPublicPrivate :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: OpenPublicPrivate :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: PolarityPragmasButNotPostulates :: [Name] -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: PolarityPragmasButNotPostulates :: [Name] -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: PragmaCompiled :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: PragmaCompiled :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: PragmaNoTerminationCheck :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: PragmaNoTerminationCheck :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: PrimitiveFunction :: Range -> Access -> IsAbstract -> Name -> Expr -> NiceDeclaration

+ Agda.Syntax.Concrete.Definitions: PrimitiveFunction :: Range -> Access -> IsAbstract -> Name -> Arg Expr -> NiceDeclaration

- Agda.Syntax.Concrete.Definitions: ShadowingInTelescope :: [(Name, [Range])] -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: ShadowingInTelescope :: List1 (Name, List2 Range) -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: UnknownFixityInMixfixDecl :: [Name] -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: UnknownFixityInMixfixDecl :: [Name] -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: UnknownNamesInFixityDecl :: [Name] -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: UnknownNamesInFixityDecl :: [Name] -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: UnknownNamesInPolarityPragmas :: [Name] -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: UnknownNamesInPolarityPragmas :: [Name] -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: UselessAbstract :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: UselessAbstract :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: UselessInstance :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: UselessInstance :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Definitions: UselessPrivate :: Range -> DeclarationWarning

+ Agda.Syntax.Concrete.Definitions: UselessPrivate :: Range -> DeclarationWarning'

- Agda.Syntax.Concrete.Fixity: warnPolarityPragmasButNotPostulates :: MonadFixityError m => [Name] -> m ()

+ Agda.Syntax.Concrete.Fixity: warnPolarityPragmasButNotPostulates :: (MonadFixityError m, HasCallStack) => [Name] -> m ()

- Agda.Syntax.Concrete.Fixity: warnUnknownFixityInMixfixDecl :: MonadFixityError m => [Name] -> m ()

+ Agda.Syntax.Concrete.Fixity: warnUnknownFixityInMixfixDecl :: (MonadFixityError m, HasCallStack) => [Name] -> m ()

- Agda.Syntax.Concrete.Fixity: warnUnknownNamesInFixityDecl :: MonadFixityError m => [Name] -> m ()

+ Agda.Syntax.Concrete.Fixity: warnUnknownNamesInFixityDecl :: (MonadFixityError m, HasCallStack) => [Name] -> m ()

- Agda.Syntax.Concrete.Fixity: warnUnknownNamesInPolarityPragmas :: MonadFixityError m => [Name] -> m ()

+ Agda.Syntax.Concrete.Fixity: warnUnknownNamesInPolarityPragmas :: (MonadFixityError m, HasCallStack) => [Name] -> m ()

- Agda.Syntax.Concrete.Generic: foldExpr :: (ExprLike a, Monoid m) => (Expr -> m) -> a -> m

+ Agda.Syntax.Concrete.Generic: foldExpr :: (ExprLike a, Monoid m, Foldable t, ExprLike b, t b ~ a) => (Expr -> m) -> a -> m

- Agda.Syntax.Concrete.Generic: mapExpr :: ExprLike a => (Expr -> Expr) -> a -> a

+ Agda.Syntax.Concrete.Generic: mapExpr :: (ExprLike a, Functor t, ExprLike b, t b ~ a) => (Expr -> Expr) -> a -> a

- Agda.Syntax.Concrete.Generic: traverseExpr :: (ExprLike a, Monad m) => (Expr -> m Expr) -> a -> m a

+ Agda.Syntax.Concrete.Generic: traverseExpr :: (ExprLike a, Monad m, Traversable t, ExprLike b, t b ~ a) => (Expr -> m Expr) -> a -> m a

- Agda.Syntax.Concrete.Name: Name :: Range -> NameInScope -> [NamePart] -> Name

+ Agda.Syntax.Concrete.Name: Name :: Range -> NameInScope -> NameParts -> Name

- Agda.Syntax.Concrete.Name: TopLevelModuleName :: Range -> [String] -> TopLevelModuleName

+ Agda.Syntax.Concrete.Name: TopLevelModuleName :: Range -> List1 String -> TopLevelModuleName

- Agda.Syntax.Concrete.Name: [moduleNameParts] :: TopLevelModuleName -> [String]

+ Agda.Syntax.Concrete.Name: [moduleNameParts] :: TopLevelModuleName -> List1 String

- Agda.Syntax.Concrete.Name: [nameNameParts] :: Name -> [NamePart]

+ Agda.Syntax.Concrete.Name: [nameNameParts] :: Name -> NameParts

- Agda.Syntax.Concrete.Name: firstNonTakenName :: (Name -> Bool) -> Name -> Name

+ Agda.Syntax.Concrete.Name: firstNonTakenName :: FreshNameMode -> (Name -> Bool) -> Name -> Name

- Agda.Syntax.Concrete.Name: nameParts :: Name -> [NamePart]

+ Agda.Syntax.Concrete.Name: nameParts :: Name -> NameParts

- Agda.Syntax.Concrete.Name: nextName :: Name -> Name

+ Agda.Syntax.Concrete.Name: nextName :: FreshNameMode -> Name -> Name

- Agda.Syntax.Concrete.Name: qnameParts :: QName -> [Name]

+ Agda.Syntax.Concrete.Name: qnameParts :: QName -> List1 Name

- Agda.Syntax.Concrete.Name: stringNameParts :: String -> [NamePart]

+ Agda.Syntax.Concrete.Name: stringNameParts :: String -> NameParts

- Agda.Syntax.Concrete.Operators: parseApplication :: [Expr] -> ScopeM Expr

+ Agda.Syntax.Concrete.Operators: parseApplication :: List2 Expr -> ScopeM Expr

- Agda.Syntax.Concrete.Operators.Parser: LamV :: [LamBinding] -> e -> ExprView e

+ Agda.Syntax.Concrete.Operators.Parser: LamV :: List1 LamBinding -> e -> ExprView e

- Agda.Syntax.Concrete.Operators.Parser: OpAppV :: QName -> Set Name -> [NamedArg (MaybePlaceholder (OpApp e))] -> ExprView e

+ Agda.Syntax.Concrete.Operators.Parser: OpAppV :: QName -> Set Name -> OpAppArgs' e -> ExprView e

- Agda.Syntax.Concrete.Pattern: patternAppView :: Pattern -> [NamedArg Pattern]

+ Agda.Syntax.Concrete.Pattern: patternAppView :: Pattern -> List1 (NamedArg Pattern)

- Agda.Syntax.Concrete.Pretty: bracesAndSemicolons :: [Doc] -> Doc

+ Agda.Syntax.Concrete.Pretty: bracesAndSemicolons :: Foldable t => t Doc -> Doc

- Agda.Syntax.Concrete.Pretty: pRecord :: Name -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe (Name, IsInstance) -> [LamBinding] -> Maybe Expr -> [Declaration] -> Doc

+ Agda.Syntax.Concrete.Pretty: pRecord :: Name -> RecordDirectives -> [LamBinding] -> Maybe Expr -> [Declaration] -> Doc

- Agda.Syntax.DoNotation: desugarDoNotation :: Range -> [DoStmt] -> ScopeM Expr

+ Agda.Syntax.DoNotation: desugarDoNotation :: Range -> List1 DoStmt -> ScopeM Expr

- Agda.Syntax.Internal: Clause :: Range -> Range -> Telescope -> NAPs -> Maybe Term -> Maybe (Arg Type) -> Bool -> Maybe Bool -> Maybe Bool -> ExpandedEllipsis -> Clause

+ Agda.Syntax.Internal: Clause :: Range -> Range -> Telescope -> NAPs -> Maybe Term -> Maybe (Arg Type) -> Bool -> Maybe Bool -> Maybe Bool -> Maybe Bool -> ExpandedEllipsis -> Clause

- Agda.Syntax.Internal: ConHead :: QName -> Induction -> [Arg QName] -> ConHead

+ Agda.Syntax.Internal: ConHead :: QName -> DataOrRecord -> Induction -> [Arg QName] -> ConHead

- Agda.Syntax.Internal: EmptyS :: Empty -> Substitution' a

+ Agda.Syntax.Internal: EmptyS :: Impossible -> Substitution' a

- Agda.Syntax.Internal: Inf :: Sort' t

+ Agda.Syntax.Internal: Inf :: IsFibrant -> Integer -> Sort' t

- Agda.Syntax.Internal: PiSort :: Dom' t (Type'' t t) -> Abs (Sort' t) -> Sort' t

+ Agda.Syntax.Internal: PiSort :: Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t

- Agda.Syntax.Internal: Plus :: Integer -> LevelAtom' t -> PlusLevel' t

+ Agda.Syntax.Internal: Plus :: Integer -> t -> PlusLevel' t

- Agda.Syntax.Internal: Strengthen :: Empty -> Substitution' a -> Substitution' a

+ Agda.Syntax.Internal: Strengthen :: Impossible -> Substitution' a -> Substitution' a

- Agda.Syntax.Internal: atomicLevel :: LevelAtom -> Level

+ Agda.Syntax.Internal: atomicLevel :: t -> Level' t

- Agda.Syntax.Internal: class PatternVars a b | b -> a

+ Agda.Syntax.Internal: class PatternVars a where {

- Agda.Syntax.Internal: dummyDom :: String -> Int -> Dom Type

+ Agda.Syntax.Internal: dummyDom :: CallStack -> Dom Type

- Agda.Syntax.Internal: dummyLevel :: String -> Int -> Level

+ Agda.Syntax.Internal: dummyLevel :: CallStack -> Level

- Agda.Syntax.Internal: dummySort :: String -> Int -> Sort

+ Agda.Syntax.Internal: dummySort :: CallStack -> Sort

- Agda.Syntax.Internal: dummyTerm :: String -> Int -> Term

+ Agda.Syntax.Internal: dummyTerm :: CallStack -> Term

- Agda.Syntax.Internal: dummyType :: String -> Int -> Type

+ Agda.Syntax.Internal: dummyType :: CallStack -> Type

- Agda.Syntax.Internal: impossibleTerm :: String -> Int -> Term

+ Agda.Syntax.Internal: impossibleTerm :: CallStack -> Term

- Agda.Syntax.Internal: patternVars :: PatternVars a b => b -> [Arg (Either a Term)]

+ Agda.Syntax.Internal: patternVars :: PatternVars a => a -> [Arg (Either (PatternVarOut a) Term)]

- Agda.Syntax.Internal: type LevelAtom = LevelAtom' Term

+ Agda.Syntax.Internal: type LevelAtom = Term

- Agda.Syntax.Internal.MetaVars: allMetas :: (TermLike a, Monoid m) => (MetaId -> m) -> a -> m

+ Agda.Syntax.Internal.MetaVars: allMetas :: (AllMetas t, TermLike t, Monoid m) => (MetaId -> m) -> t -> m

- Agda.Syntax.Internal.MetaVars: allMetasList :: TermLike a => a -> [MetaId]

+ Agda.Syntax.Internal.MetaVars: allMetasList :: AllMetas a => a -> [MetaId]

- Agda.Syntax.Internal.MetaVars: firstMeta :: TermLike a => a -> Maybe MetaId

+ Agda.Syntax.Internal.MetaVars: firstMeta :: AllMetas a => a -> Maybe MetaId

- Agda.Syntax.Internal.MetaVars: noMetas :: TermLike a => a -> Bool

+ Agda.Syntax.Internal.MetaVars: noMetas :: AllMetas a => a -> Bool

- Agda.Syntax.Internal.Names: namesIn :: (NamesIn a, Foldable f, NamesIn b, f b ~ a) => a -> Set QName

+ Agda.Syntax.Internal.Names: namesIn :: (NamesIn a, Collection QName m) => a -> m

- Agda.Syntax.Internal.Pattern: class LabelPatVars a b i | b -> i

+ Agda.Syntax.Internal.Pattern: class LabelPatVars a b where {

- Agda.Syntax.Internal.Pattern: class PatternVarModalities p x | p -> x

+ Agda.Syntax.Internal.Pattern: class PatternVarModalities p where {

- Agda.Syntax.Internal.Pattern: labelPatVars :: (LabelPatVars a b i, Traversable f, LabelPatVars a' b' i, f a' ~ a, f b' ~ b) => a -> State [i] b

+ Agda.Syntax.Internal.Pattern: labelPatVars :: (LabelPatVars a b, Traversable f, LabelPatVars a' b', PatVarLabel b ~ PatVarLabel b', f a' ~ a, f b' ~ b) => a -> State [PatVarLabel b] b

- Agda.Syntax.Internal.Pattern: numberPatVars :: LabelPatVars a b Int => Int -> Permutation -> a -> b

+ Agda.Syntax.Internal.Pattern: numberPatVars :: (LabelPatVars a b, PatVarLabel b ~ Int) => Int -> Permutation -> a -> b

- Agda.Syntax.Internal.Pattern: patternVarModalities :: PatternVarModalities p x => p -> [(x, Modality)]

+ Agda.Syntax.Internal.Pattern: patternVarModalities :: PatternVarModalities p => p -> [(PatVar p, Modality)]

- Agda.Syntax.Internal.Pattern: unlabelPatVars :: (LabelPatVars a b i, Traversable f, LabelPatVars a' b' i, f a' ~ a, f b' ~ b) => b -> a

+ Agda.Syntax.Internal.Pattern: unlabelPatVars :: (LabelPatVars a b, Traversable f, LabelPatVars a' b', f a' ~ a, f b' ~ b) => b -> a

- Agda.Syntax.Internal.Pattern: unnumberPatVars :: LabelPatVars a b i => b -> a

+ Agda.Syntax.Internal.Pattern: unnumberPatVars :: LabelPatVars a b => b -> a

- Agda.Syntax.Literal: LitChar :: Range -> !Char -> Literal

+ Agda.Syntax.Literal: LitChar :: !Char -> Literal

- Agda.Syntax.Literal: LitFloat :: Range -> !Double -> Literal

+ Agda.Syntax.Literal: LitFloat :: !Double -> Literal

- Agda.Syntax.Literal: LitMeta :: Range -> AbsolutePath -> MetaId -> Literal

+ Agda.Syntax.Literal: LitMeta :: AbsolutePath -> MetaId -> Literal

- Agda.Syntax.Literal: LitNat :: Range -> !Integer -> Literal

+ Agda.Syntax.Literal: LitNat :: !Integer -> Literal

- Agda.Syntax.Literal: LitQName :: Range -> QName -> Literal

+ Agda.Syntax.Literal: LitQName :: !QName -> Literal

- Agda.Syntax.Literal: LitString :: Range -> String -> Literal

+ Agda.Syntax.Literal: LitString :: !Text -> Literal

- Agda.Syntax.Literal: LitWord64 :: Range -> !Word64 -> Literal

+ Agda.Syntax.Literal: LitWord64 :: !Word64 -> Literal

- Agda.Syntax.Parser.Layout: withLayout :: LexAction r -> LexAction r

+ Agda.Syntax.Parser.Layout: withLayout :: Keyword -> LexAction r -> LexAction r

- Agda.Syntax.Parser.LexActions: literal :: Read a => (Range -> a -> Literal) -> LexAction Token

+ Agda.Syntax.Parser.LexActions: literal :: Read a => (a -> Literal) -> LexAction Token

- Agda.Syntax.Parser.LexActions: literal' :: (String -> a) -> (Range -> a -> Literal) -> LexAction Token

+ Agda.Syntax.Parser.LexActions: literal' :: (String -> a) -> (a -> Literal) -> LexAction Token

- Agda.Syntax.Parser.LexActions: withLayout :: LexAction r -> LexAction r

+ Agda.Syntax.Parser.LexActions: withLayout :: Keyword -> LexAction r -> LexAction r

- Agda.Syntax.Parser.Monad: Layout :: Int32 -> LayoutContext

+ Agda.Syntax.Parser.Monad: Layout :: Keyword -> LayoutStatus -> Column -> LayoutBlock

- Agda.Syntax.Parser.Monad: PState :: !SrcFile -> !PositionWithoutFile -> !PositionWithoutFile -> String -> !Char -> String -> [LayoutContext] -> [LexState] -> ParseFlags -> ParseState

+ Agda.Syntax.Parser.Monad: PState :: !SrcFile -> !PositionWithoutFile -> !PositionWithoutFile -> String -> !Char -> String -> LayoutContext -> LayoutStatus -> Keyword -> [LexState] -> ParseFlags -> ![ParseWarning] -> ParseState

- Agda.Syntax.Parser.Monad: [parseLayout] :: ParseState -> [LayoutContext]

+ Agda.Syntax.Parser.Monad: [parseLayout] :: ParseState -> LayoutContext

- Agda.Syntax.Parser.Tokens: TokLiteral :: Literal -> Token

+ Agda.Syntax.Parser.Tokens: TokLiteral :: RLiteral -> Token

- Agda.Syntax.Position: class HasRange t

+ Agda.Syntax.Position: class HasRange a

- Agda.Syntax.Position: class HasRange t => SetRange t

+ Agda.Syntax.Position: class HasRange a => SetRange a

- Agda.Syntax.Position: getRange :: HasRange t => t -> Range

+ Agda.Syntax.Position: getRange :: (HasRange a, Foldable t, HasRange b, t b ~ a) => a -> Range

- Agda.Syntax.Position: killRange :: KillRange a => KillRangeT a

+ Agda.Syntax.Position: killRange :: (KillRange a, Functor f, KillRange b, f b ~ a) => KillRangeT a

- Agda.Syntax.Position: setRange :: SetRange t => Range -> t -> t

+ Agda.Syntax.Position: setRange :: (SetRange a, Functor f, SetRange b, f b ~ a) => Range -> a -> a

- Agda.Syntax.Reflected: AbsurdClause :: [Arg Pattern] -> Clause

+ Agda.Syntax.Reflected: AbsurdClause :: [(Text, Arg Type)] -> [Arg Pattern] -> Clause

- Agda.Syntax.Reflected: AbsurdP :: Pattern

+ Agda.Syntax.Reflected: AbsurdP :: Int -> Pattern

- Agda.Syntax.Reflected: Clause :: [Arg Pattern] -> Term -> Clause

+ Agda.Syntax.Reflected: Clause :: [(Text, Arg Type)] -> [Arg Pattern] -> Term -> Clause

- Agda.Syntax.Reflected: DotP :: Pattern

+ Agda.Syntax.Reflected: DotP :: Term -> Pattern

- Agda.Syntax.Reflected: ExtLam :: [Clause] -> Elims -> Term

+ Agda.Syntax.Reflected: ExtLam :: List1 Clause -> Elims -> Term

- Agda.Syntax.Reflected: VarP :: String -> Pattern

+ Agda.Syntax.Reflected: VarP :: Int -> Pattern

- Agda.Syntax.Scope.Base: ConstructorName :: NonEmpty AbstractName -> ResolvedName

+ Agda.Syntax.Scope.Base: ConstructorName :: Set Induction -> List1 AbstractName -> ResolvedName

- Agda.Syntax.Scope.Base: DefinedName :: Access -> AbstractName -> ResolvedName

+ Agda.Syntax.Scope.Base: DefinedName :: Access -> AbstractName -> Suffix -> ResolvedName

- Agda.Syntax.Scope.Base: FieldName :: NonEmpty AbstractName -> ResolvedName

+ Agda.Syntax.Scope.Base: FieldName :: List1 AbstractName -> ResolvedName

- Agda.Syntax.Scope.Base: PatternSynResName :: NonEmpty AbstractName -> ResolvedName

+ Agda.Syntax.Scope.Base: PatternSynResName :: List1 AbstractName -> ResolvedName

- Agda.Syntax.Scope.Base: Scope :: ModuleName -> [ModuleName] -> ScopeNameSpaces -> Map QName ModuleName -> Maybe DataOrRecord -> Scope

+ Agda.Syntax.Scope.Base: Scope :: ModuleName -> [ModuleName] -> ScopeNameSpaces -> Map QName ModuleName -> Maybe DataOrRecordModule -> Scope

- Agda.Syntax.Scope.Base: ScopeInfo :: ModuleName -> Map ModuleName Scope -> LocalVars -> LocalVars -> PrecedenceStack -> NameMap -> ModuleMap -> InScopeSet -> Fixities -> Polarities -> ScopeInfo

+ Agda.Syntax.Scope.Base: ScopeInfo :: ModuleName -> Map ModuleName Scope -> LocalVars -> LocalVars -> !PrecedenceStack -> NameMap -> ModuleMap -> InScopeSet -> Fixities -> Polarities -> ScopeInfo

- Agda.Syntax.Scope.Base: [_scopePrecedence] :: ScopeInfo -> PrecedenceStack

+ Agda.Syntax.Scope.Base: [_scopePrecedence] :: ScopeInfo -> !PrecedenceStack

- Agda.Syntax.Scope.Base: [scopeDatatypeModule] :: Scope -> Maybe DataOrRecord

+ Agda.Syntax.Scope.Base: [scopeDatatypeModule] :: Scope -> Maybe DataOrRecordModule

- Agda.Syntax.Scope.Base: lensAmodName :: Functor m => (ModuleName -> m ModuleName) -> AbstractModule -> m AbstractModule

+ Agda.Syntax.Scope.Base: lensAmodName :: Lens' ModuleName AbstractModule

- Agda.Syntax.Scope.Base: lensAnameName :: Functor m => (QName -> m QName) -> AbstractName -> m AbstractName

+ Agda.Syntax.Scope.Base: lensAnameName :: Lens' QName AbstractName

- Agda.Syntax.Scope.Base: type NameMap = Map QName (NonEmpty QName)

+ Agda.Syntax.Scope.Base: type NameMap = Map QName NameMapEntry

- Agda.Syntax.Scope.Monad: ScopeMemo :: Ren QName -> [(ModuleName, (ModuleName, Bool))] -> ScopeMemo

+ Agda.Syntax.Scope.Monad: ScopeMemo :: Ren QName -> Map ModuleName (ModuleName, Bool) -> ScopeMemo

- Agda.Syntax.Scope.Monad: [memoModules] :: ScopeMemo -> [(ModuleName, (ModuleName, Bool))]

+ Agda.Syntax.Scope.Monad: [memoModules] :: ScopeMemo -> Map ModuleName (ModuleName, Bool)

- Agda.Syntax.Scope.Monad: createModule :: Maybe DataOrRecord -> ModuleName -> ScopeM ()

+ Agda.Syntax.Scope.Monad: createModule :: Maybe DataOrRecordModule -> ModuleName -> ScopeM ()

- Agda.Syntax.Scope.Monad: isDatatypeModule :: ReadTCState m => ModuleName -> m (Maybe DataOrRecord)

+ Agda.Syntax.Scope.Monad: isDatatypeModule :: ReadTCState m => ModuleName -> m (Maybe DataOrRecordModule)

- Agda.Syntax.Scope.Monad: tryResolveName :: (ReadTCState m, MonadError (NonEmpty QName) m) => KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName

+ Agda.Syntax.Scope.Monad: tryResolveName :: (ReadTCState m, HasBuiltins m, MonadError (List1 QName) m) => KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName

- Agda.Syntax.Translation.AbstractToConcrete: abstractToConcreteCtx :: (ToConcrete a c, MonadAbsToCon m) => Precedence -> a -> m c

+ Agda.Syntax.Translation.AbstractToConcrete: abstractToConcreteCtx :: (ToConcrete a, MonadAbsToCon m) => Precedence -> a -> m (ConOfAbs a)

- Agda.Syntax.Translation.AbstractToConcrete: abstractToConcreteHiding :: (LensHiding i, ToConcrete a c, MonadAbsToCon m) => i -> a -> m c

+ Agda.Syntax.Translation.AbstractToConcrete: abstractToConcreteHiding :: (LensHiding i, ToConcrete a, MonadAbsToCon m) => i -> a -> m (ConOfAbs a)

- Agda.Syntax.Translation.AbstractToConcrete: abstractToConcreteScope :: (ToConcrete a c, MonadAbsToCon m) => ScopeInfo -> a -> m c

+ Agda.Syntax.Translation.AbstractToConcrete: abstractToConcreteScope :: (ToConcrete a, MonadAbsToCon m) => ScopeInfo -> a -> m (ConOfAbs a)

- Agda.Syntax.Translation.AbstractToConcrete: abstractToConcrete_ :: (ToConcrete a c, MonadAbsToCon m) => a -> m c

+ Agda.Syntax.Translation.AbstractToConcrete: abstractToConcrete_ :: (ToConcrete a, MonadAbsToCon m) => a -> m (ConOfAbs a)

- Agda.Syntax.Translation.AbstractToConcrete: bindToConcrete :: ToConcrete a c => a -> (c -> AbsToCon b) -> AbsToCon b

+ Agda.Syntax.Translation.AbstractToConcrete: bindToConcrete :: ToConcrete a => a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b

- Agda.Syntax.Translation.AbstractToConcrete: class ToConcrete a c | a -> c

+ Agda.Syntax.Translation.AbstractToConcrete: class ToConcrete a where {

- Agda.Syntax.Translation.AbstractToConcrete: toConcrete :: ToConcrete a c => a -> AbsToCon c

+ Agda.Syntax.Translation.AbstractToConcrete: toConcrete :: ToConcrete a => a -> AbsToCon (ConOfAbs a)

- Agda.Syntax.Translation.AbstractToConcrete: toConcreteCtx :: ToConcrete a c => Precedence -> a -> AbsToCon c

+ Agda.Syntax.Translation.AbstractToConcrete: toConcreteCtx :: ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)

- Agda.Syntax.Translation.ConcreteToAbstract: class ToAbstract concrete abstract | concrete -> abstract

+ Agda.Syntax.Translation.ConcreteToAbstract: class ToAbstract c where {

- Agda.Syntax.Translation.ConcreteToAbstract: concreteToAbstract :: ToAbstract c a => ScopeInfo -> c -> ScopeM a

+ Agda.Syntax.Translation.ConcreteToAbstract: concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)

- Agda.Syntax.Translation.ConcreteToAbstract: concreteToAbstract_ :: ToAbstract c a => c -> ScopeM a

+ Agda.Syntax.Translation.ConcreteToAbstract: concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)

- Agda.Syntax.Translation.ConcreteToAbstract: localToAbstract :: ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM b

+ Agda.Syntax.Translation.ConcreteToAbstract: localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b

- Agda.Syntax.Translation.ConcreteToAbstract: toAbstract :: ToAbstract concrete abstract => concrete -> ScopeM abstract

+ Agda.Syntax.Translation.ConcreteToAbstract: toAbstract :: ToAbstract c => c -> ScopeM (AbsOfCon c)

- Agda.Syntax.Translation.InternalToAbstract: class Reify i a | i -> a

+ Agda.Syntax.Translation.InternalToAbstract: class Reify i where {

- Agda.Syntax.Translation.InternalToAbstract: reify :: (Reify i a, MonadReify m) => i -> m a

+ Agda.Syntax.Translation.InternalToAbstract: reify :: (Reify i, MonadReify m) => i -> m (ReifiesTo i)

- Agda.Syntax.Translation.InternalToAbstract: reifyUnblocked :: Reify i a => i -> TCM a

+ Agda.Syntax.Translation.InternalToAbstract: reifyUnblocked :: Reify i => i -> TCM (ReifiesTo i)

- Agda.Syntax.Translation.InternalToAbstract: reifyWhen :: (Reify i a, MonadReify m) => Bool -> i -> m a

+ Agda.Syntax.Translation.InternalToAbstract: reifyWhen :: (Reify i, MonadReify m) => Bool -> i -> m (ReifiesTo i)

- Agda.Syntax.Translation.InternalToAbstract: type MonadReify m = (MonadReduce m, MonadAddContext m, MonadInteractionPoints m, MonadFresh NameId m, HasConstInfo m, HasOptions m, HasBuiltins m, MonadDebug m)

+ Agda.Syntax.Translation.InternalToAbstract: type MonadReify m = (PureTCM m, MonadInteractionPoints m, MonadFresh NameId m)

- Agda.Syntax.Translation.ReflectedToAbstract: class ToAbstract r a | r -> a

+ Agda.Syntax.Translation.ReflectedToAbstract: class ToAbstract r where {

- Agda.Syntax.Translation.ReflectedToAbstract: toAbstract :: (ToAbstract r a, MonadReflectedToAbstract m) => r -> m a

+ Agda.Syntax.Translation.ReflectedToAbstract: toAbstract :: (ToAbstract r, Traversable t, ToAbstract s, t s ~ r, t (AbsOfRef s) ~ AbsOfRef r) => MonadReflectedToAbstract m => r -> m (AbsOfRef r)

- Agda.Syntax.Translation.ReflectedToAbstract: toAbstractWithoutImplicit :: (ToAbstract r a, MonadFresh NameId m, MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasOptions m, HasConstInfo m) => r -> m a

+ 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: toAbstract_ :: (ToAbstract r a, MonadFresh NameId m, MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasOptions m, HasConstInfo m) => r -> m a

+ 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: type MonadReflectedToAbstract m = (MonadReader Names m, MonadFresh NameId m, MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasOptions m, HasConstInfo m)

+ Agda.Syntax.Translation.ReflectedToAbstract: type MonadReflectedToAbstract m = (MonadReader Vars m, MonadFresh NameId m, MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasOptions m, HasBuiltins m, HasConstInfo m)

- Agda.Syntax.Treeless: CTData :: QName -> CaseType

+ Agda.Syntax.Treeless: CTData :: Quantity -> QName -> CaseType

- Agda.Syntax.Treeless: Compiled :: TTerm -> [Bool] -> Compiled

+ Agda.Syntax.Treeless: Compiled :: TTerm -> Maybe [ArgUsage] -> Compiled

- Agda.Syntax.Treeless: [cArgUsage] :: Compiled -> [Bool]

+ Agda.Syntax.Treeless: [cArgUsage] :: Compiled -> Maybe [ArgUsage]

- Agda.Termination.CallGraph: fromList :: [Call cinfo] -> CallGraph cinfo

+ Agda.Termination.CallGraph: fromList :: Collection el coll => [el] -> coll

- Agda.Termination.CutOff: CutOff :: Int -> CutOff

+ Agda.Termination.CutOff: CutOff :: !Int -> CutOff

- Agda.TypeChecking.Abstract: piAbstract :: WithHiding (Term, EqualityView) -> Type -> TCM Type

+ Agda.TypeChecking.Abstract: piAbstract :: Arg (Term, EqualityView) -> Type -> TCM Type

- Agda.TypeChecking.Abstract: piAbstractTerm :: Hiding -> Term -> Type -> Type -> TCM Type

+ Agda.TypeChecking.Abstract: piAbstractTerm :: ArgInfo -> Term -> Type -> Type -> TCM Type

- Agda.TypeChecking.Abstract: swap01 :: Subst Term a => a -> a

+ Agda.TypeChecking.Abstract: swap01 :: TermSubst a => a -> a

- Agda.TypeChecking.CheckInternal: Action :: (Type -> Term -> m Term) -> (Type -> Term -> m Term) -> (Relevance -> Relevance -> Relevance) -> Action m

+ Agda.TypeChecking.CheckInternal: Action :: (Type -> Term -> m Term) -> (Type -> Term -> m Term) -> (Modality -> Modality -> Modality) -> (Term -> m Term) -> Action m

- Agda.TypeChecking.CheckInternal: defaultAction :: Monad m => Action m

+ Agda.TypeChecking.CheckInternal: defaultAction :: PureTCM m => Action m

- Agda.TypeChecking.CheckInternal: shouldBeSort :: (MonadReduce m, MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Type -> m Sort

+ Agda.TypeChecking.CheckInternal: shouldBeSort :: (PureTCM m, MonadBlock m, MonadError TCErr m) => Type -> m Sort

- Agda.TypeChecking.CompiledClause: Fail :: CompiledClauses' a

+ Agda.TypeChecking.CompiledClause: Fail :: [Arg ArgName] -> CompiledClauses' a

- Agda.TypeChecking.CompiledClause.Compile: substBody :: Subst t a => Int -> Int -> t -> a -> a

+ Agda.TypeChecking.CompiledClause.Compile: substBody :: Subst a => Int -> Int -> SubstArg a -> a -> a

- Agda.TypeChecking.Constraints: addConstraintTCM :: Constraint -> TCM ()

+ Agda.TypeChecking.Constraints: addConstraintTCM :: Blocker -> Constraint -> TCM ()

- Agda.TypeChecking.Constraints: wakeConstraints' :: (ProblemConstraint -> TCM Bool) -> TCM ()

+ Agda.TypeChecking.Constraints: wakeConstraints' :: (ProblemConstraint -> WakeUp) -> TCM ()

- Agda.TypeChecking.Constraints: wakeConstraintsTCM :: (ProblemConstraint -> TCM Bool) -> TCM ()

+ Agda.TypeChecking.Constraints: wakeConstraintsTCM :: (ProblemConstraint -> WakeUp) -> TCM ()

- Agda.TypeChecking.Conversion: equalLevel :: MonadConversion m => Level -> Level -> m ()

+ Agda.TypeChecking.Conversion: equalLevel :: forall m. MonadConversion m => Level -> Level -> m ()

- Agda.TypeChecking.Conversion: forallFaceMaps :: MonadConversion m => Term -> (Map Int Bool -> MetaId -> Term -> m a) -> (Substitution -> m a) -> m [a]

+ Agda.TypeChecking.Conversion: forallFaceMaps :: MonadConversion m => Term -> (Map Int Bool -> Blocker -> Term -> m a) -> (Substitution -> m a) -> m [a]

- Agda.TypeChecking.Conversion: type MonadConversion m = (MonadReduce m, MonadAddContext m, MonadConstraint m, MonadMetaSolver m, MonadError TCErr m, MonadWarning m, MonadDebug m, MonadStatistics m, MonadFresh ProblemId m, MonadFresh Int m, HasBuiltins m, HasConstInfo m, HasOptions m, MonadFail m)

+ Agda.TypeChecking.Conversion: type MonadConversion m = (PureTCM m, MonadConstraint m, MonadMetaSolver m, MonadError TCErr m, MonadWarning m, MonadStatistics m, MonadFresh ProblemId m, MonadFresh Int m, MonadFail m)

- Agda.TypeChecking.Conversion.Pure: pureCompareAs :: (MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m) => Comparison -> CompareAs -> Term -> Term -> m Bool

+ Agda.TypeChecking.Conversion.Pure: pureCompareAs :: (PureTCM m, MonadBlock m) => Comparison -> CompareAs -> Term -> Term -> m Bool

- Agda.TypeChecking.Conversion.Pure: pureEqualTerm :: (MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m) => Type -> Term -> Term -> m Bool

+ Agda.TypeChecking.Conversion.Pure: pureEqualTerm :: (PureTCM m, MonadBlock m) => Type -> Term -> Term -> m Bool

- Agda.TypeChecking.Conversion.Pure: runPureConversion :: (ReadTCState m, MonadDebug m, HasOptions m, MonadTCEnv m, Show a) => PureConversionT m a -> m (Either TCErr a)

+ Agda.TypeChecking.Conversion.Pure: runPureConversion :: (MonadBlock m, PureTCM m, Show a) => PureConversionT m a -> m (Maybe a)

- Agda.TypeChecking.Coverage.Match: applySplitPSubst :: Subst Term a => SplitPSubstitution -> a -> a

+ Agda.TypeChecking.Coverage.Match: applySplitPSubst :: TermSubst a => SplitPSubstitution -> a -> a

- Agda.TypeChecking.Coverage.Match: match :: (MonadReduce m, HasConstInfo m, HasBuiltins m) => [Clause] -> [NamedArg SplitPattern] -> m (Match (Nat, SplitInstantiation))

+ Agda.TypeChecking.Coverage.Match: match :: PureTCM m => [Clause] -> [NamedArg SplitPattern] -> m (Match (Nat, SplitInstantiation))

- Agda.TypeChecking.Coverage.Match: matchClause :: (MonadReduce m, HasConstInfo m, HasBuiltins m) => [NamedArg SplitPattern] -> Clause -> m MatchResult

+ Agda.TypeChecking.Coverage.Match: matchClause :: PureTCM m => [NamedArg SplitPattern] -> Clause -> m MatchResult

- Agda.TypeChecking.Datatypes: RecordCon :: HasEta -> [Dom QName] -> ConstructorInfo

+ Agda.TypeChecking.Datatypes: RecordCon :: PatternOrCopattern -> HasEta -> [Dom QName] -> ConstructorInfo

- Agda.TypeChecking.Datatypes: consOfHIT :: QName -> TCM Bool

+ Agda.TypeChecking.Datatypes: consOfHIT :: HasConstInfo m => QName -> m Bool

- Agda.TypeChecking.Datatypes: getConType :: (MonadReduce m, MonadAddContext m, HasConstInfo m, MonadDebug m) => ConHead -> Type -> m (Maybe ((QName, Type, Args), Type))

+ Agda.TypeChecking.Datatypes: getConType :: PureTCM m => ConHead -> Type -> m (Maybe ((QName, Type, Args), Type))

- Agda.TypeChecking.Datatypes: getFullyAppliedConType :: (HasConstInfo m, MonadReduce m, MonadDebug m) => ConHead -> Type -> m (Maybe ((QName, Type, Args), Type))

+ Agda.TypeChecking.Datatypes: getFullyAppliedConType :: PureTCM m => ConHead -> Type -> m (Maybe ((QName, Type, Args), Type))

- Agda.TypeChecking.Datatypes: getNumberOfParameters :: QName -> TCM (Maybe Nat)

+ Agda.TypeChecking.Datatypes: getNumberOfParameters :: HasConstInfo m => QName -> m (Maybe Nat)

- Agda.TypeChecking.Errors: applyFlagsToTCWarnings :: [TCWarning] -> TCM [TCWarning]

+ Agda.TypeChecking.Errors: applyFlagsToTCWarnings :: HasOptions m => [TCWarning] -> m [TCWarning]

- Agda.TypeChecking.Errors: tcWarningsToError :: [TCWarning] -> TCM a

+ Agda.TypeChecking.Errors: tcWarningsToError :: [TCWarning] -> TCM ()

- Agda.TypeChecking.EtaExpand: etaExpandAction :: (MonadReduce m, MonadTCEnv m, HasOptions m, HasConstInfo m, MonadDebug m) => Action m

+ Agda.TypeChecking.EtaExpand: etaExpandAction :: PureTCM m => Action m

- Agda.TypeChecking.EtaExpand: etaExpandOnce :: (MonadReduce m, MonadTCEnv m, HasOptions m, HasConstInfo m, MonadDebug m) => Type -> Term -> m Term

+ Agda.TypeChecking.EtaExpand: etaExpandOnce :: PureTCM m => Type -> Term -> m Term

- Agda.TypeChecking.Free.Lazy: underConstructor :: (MonadReader r m, LensFlexRig a r, Semigroup a) => ConHead -> m z -> m z

+ Agda.TypeChecking.Free.Lazy: underConstructor :: (MonadReader r m, LensFlexRig a r, Semigroup a) => ConHead -> Elims -> m z -> m z

- Agda.TypeChecking.Free.Reduce: class (PrecomputeFreeVars a, Subst Term a) => ForceNotFree a

+ Agda.TypeChecking.Free.Reduce: class (PrecomputeFreeVars a, Subst a) => ForceNotFree a

- Agda.TypeChecking.Implicit: implicitArgs :: (MonadReduce m, MonadMetaSolver m, MonadDebug m, MonadTCM m) => Int -> (Hiding -> Bool) -> Type -> m (Args, Type)

+ Agda.TypeChecking.Implicit: implicitArgs :: (PureTCM m, MonadMetaSolver m, MonadTCM m) => Int -> (Hiding -> Bool) -> Type -> m (Args, Type)

- Agda.TypeChecking.Implicit: implicitNamedArgs :: (MonadReduce m, MonadMetaSolver m, MonadDebug m, MonadTCM m) => Int -> (Hiding -> ArgName -> Bool) -> Type -> m (NamedArgs, Type)

+ Agda.TypeChecking.Implicit: implicitNamedArgs :: (PureTCM m, MonadMetaSolver m, MonadTCM m) => Int -> (Hiding -> ArgName -> Bool) -> Type -> m (NamedArgs, Type)

- Agda.TypeChecking.Implicit: newMetaArg :: MonadMetaSolver m => ArgInfo -> ArgName -> Comparison -> Type -> m (MetaId, Term)

+ Agda.TypeChecking.Implicit: newMetaArg :: (PureTCM m, MonadMetaSolver m) => ArgInfo -> ArgName -> Comparison -> Type -> m (MetaId, Term)

- Agda.TypeChecking.Injectivity: functionInverse :: (MonadReduce m, MonadError TCErr m, HasBuiltins m, HasConstInfo m) => Term -> m InvView

+ Agda.TypeChecking.Injectivity: functionInverse :: (PureTCM m, MonadError TCErr m) => Term -> m InvView

- Agda.TypeChecking.Injectivity: headSymbol' :: (MonadReduce m, MonadError TCErr m, MonadDebug m, HasBuiltins m) => Term -> m (Maybe TermHead)

+ Agda.TypeChecking.Injectivity: headSymbol' :: (PureTCM m, MonadError TCErr m) => Term -> m (Maybe TermHead)

- Agda.TypeChecking.Injectivity: instantiateVarHeads :: forall m c. (MonadReduce m, MonadError TCErr m, MonadDebug m, HasBuiltins m) => QName -> Elims -> InversionMap c -> m (Maybe (InversionMap c))

+ Agda.TypeChecking.Injectivity: instantiateVarHeads :: forall m c. (PureTCM m, MonadError TCErr m) => QName -> Elims -> InversionMap c -> m (Maybe (InversionMap c))

- Agda.TypeChecking.Injectivity: useInjectivity :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()

+ Agda.TypeChecking.Injectivity: useInjectivity :: MonadConversion m => CompareDirection -> Blocker -> CompareAs -> Term -> Term -> m ()

- Agda.TypeChecking.Irrelevance: hideAndRelParams :: Dom a -> Dom a

+ Agda.TypeChecking.Irrelevance: hideAndRelParams :: (LensHiding a, LensRelevance a) => a -> a

- Agda.TypeChecking.Irrelevance: isIrrelevantOrPropM :: (LensRelevance a, LensSort a, PrettyTCM a, MonadReduce m, MonadDebug m) => a -> m Bool

+ Agda.TypeChecking.Irrelevance: isIrrelevantOrPropM :: (LensRelevance a, LensSort a, PrettyTCM a, PureTCM m, MonadBlock m) => a -> m Bool

- Agda.TypeChecking.Irrelevance: isPropM :: (LensSort a, PrettyTCM a, MonadReduce m, MonadDebug m) => a -> m Bool

+ Agda.TypeChecking.Irrelevance: isPropM :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m) => a -> m Bool

- Agda.TypeChecking.Irrelevance: usableMod :: UsableModality a => Modality -> a -> TCM Bool

+ 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: usableRel :: UsableRelevance a => Relevance -> a -> TCM Bool

+ Agda.TypeChecking.Irrelevance: usableRel :: (UsableRelevance a, ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m) => Relevance -> a -> m Bool

- Agda.TypeChecking.Level: SingleClosed :: Integer -> SingleLevel

+ Agda.TypeChecking.Level: SingleClosed :: Integer -> SingleLevel' t

- Agda.TypeChecking.Level: SinglePlus :: PlusLevel -> SingleLevel

+ Agda.TypeChecking.Level: SinglePlus :: PlusLevel' t -> SingleLevel' t

- Agda.TypeChecking.Level: isLevelType :: (HasBuiltins m, MonadReduce m) => Type -> m Bool

+ Agda.TypeChecking.Level: isLevelType :: PureTCM m => Type -> m Bool

- Agda.TypeChecking.Level: levelMaxView :: Level -> NonEmpty SingleLevel

+ Agda.TypeChecking.Level: levelMaxView :: Level' t -> NonEmpty (SingleLevel' t)

- Agda.TypeChecking.Level: levelView :: (HasBuiltins m, MonadReduce m, MonadDebug m) => Term -> m Level

+ Agda.TypeChecking.Level: levelView :: PureTCM m => Term -> m Level

- Agda.TypeChecking.Level: levelView' :: (HasBuiltins m, MonadReduce m, MonadDebug m) => Term -> m Level

+ Agda.TypeChecking.Level: levelView' :: PureTCM m => Term -> m Level

- Agda.TypeChecking.Level: singleLevelView :: Level -> Maybe SingleLevel

+ Agda.TypeChecking.Level: singleLevelView :: Level' t -> Maybe (SingleLevel' t)

- Agda.TypeChecking.Level: unSingleLevel :: SingleLevel -> Level

+ Agda.TypeChecking.Level: unSingleLevel :: SingleLevel' t -> Level' t

- Agda.TypeChecking.Level.Solve: defaultLevelsToZero :: forall m. MonadMetaSolver m => IntSet -> m ()

+ Agda.TypeChecking.Level.Solve: defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => IntSet -> m ()

- Agda.TypeChecking.Level.Solve: defaultOpenLevelsToZero :: MonadMetaSolver m => m a -> m a

+ Agda.TypeChecking.Level.Solve: defaultOpenLevelsToZero :: (PureTCM m, MonadMetaSolver m) => m a -> m a

- Agda.TypeChecking.MetaVars: class (TermLike a, Subst Term a, Reduce a) => ReduceAndEtaContract a

+ Agda.TypeChecking.MetaVars: class (TermLike a, TermSubst a, Reduce a) => ReduceAndEtaContract a

- Agda.TypeChecking.MetaVars: etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, Reduce t) => Blocked t -> m (Blocked t)

+ Agda.TypeChecking.MetaVars: etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, IsMeta t, Reduce t) => Blocked t -> m (Blocked t)

- Agda.TypeChecking.MetaVars: etaExpandProjectedVar :: (PrettyTCM a, Subst Term a) => Int -> a -> TCM c -> (a -> TCM c) -> TCM c

+ Agda.TypeChecking.MetaVars: etaExpandProjectedVar :: (PrettyTCM a, TermSubst a) => Int -> a -> TCM c -> (a -> TCM c) -> TCM c

- Agda.TypeChecking.MetaVars: expandProjectedVars :: (Show a, PrettyTCM a, NoProjectedVar a, ReduceAndEtaContract a, PrettyTCM b, Subst Term b) => a -> b -> (a -> b -> TCM c) -> TCM c

+ Agda.TypeChecking.MetaVars: expandProjectedVars :: (Show a, PrettyTCM a, NoProjectedVar a, ReduceAndEtaContract a, PrettyTCM b, TermSubst b) => a -> b -> (a -> b -> TCM c) -> TCM c

- Agda.TypeChecking.MetaVars: noProjectedVar :: NoProjectedVar a => a -> Either ProjVarExc ()

+ Agda.TypeChecking.MetaVars: noProjectedVar :: (NoProjectedVar a, NoProjectedVar b, Foldable t, t b ~ a) => a -> Either ProjectedVar ()

- Agda.TypeChecking.MetaVars: postponeTypeCheckingProblem :: TypeCheckingProblem -> TCM Bool -> TCM Term

+ Agda.TypeChecking.MetaVars: postponeTypeCheckingProblem :: TypeCheckingProblem -> Blocker -> TCM Term

- Agda.TypeChecking.MetaVars: reduceAndEtaContract :: (ReduceAndEtaContract a, Traversable f, TermLike b, Subst Term b, Reduce b, ReduceAndEtaContract b, f b ~ a) => a -> TCM a

+ Agda.TypeChecking.MetaVars: reduceAndEtaContract :: (ReduceAndEtaContract a, Traversable f, TermLike b, Subst b, Reduce b, ReduceAndEtaContract b, f b ~ a) => a -> TCM a

- Agda.TypeChecking.MetaVars: unblockedTester :: Type -> TCM Bool

+ Agda.TypeChecking.MetaVars: unblockedTester :: Type -> TCM Blocker

- Agda.TypeChecking.MetaVars.Occurs: abort :: TypeError -> OccursM a

+ Agda.TypeChecking.MetaVars.Occurs: abort :: Blocker -> TypeError -> OccursM a

- Agda.TypeChecking.MetaVars.Occurs: anyRigid :: (AnyRigid a, MonadReduce tcm, MonadAddContext tcm) => (Nat -> tcm Bool) -> a -> tcm Bool

+ Agda.TypeChecking.MetaVars.Occurs: anyRigid :: (AnyRigid a, PureTCM tcm) => (Nat -> tcm Bool) -> a -> tcm Bool

- Agda.TypeChecking.MetaVars.Occurs: hasBadRigid :: (MonadReduce m, HasConstInfo m, MonadAddContext m) => (Nat -> Bool) -> Term -> ExceptT () m Bool

+ Agda.TypeChecking.MetaVars.Occurs: hasBadRigid :: PureTCM m => (Nat -> Bool) -> Term -> ExceptT () m Bool

- Agda.TypeChecking.MetaVars.Occurs: patternViolation' :: MonadTCM m => Int -> String -> m a

+ Agda.TypeChecking.MetaVars.Occurs: patternViolation' :: MonadTCM m => Blocker -> Int -> String -> m a

- Agda.TypeChecking.MetaVars.Occurs: prune :: MonadMetaSolver m => MetaId -> Args -> (Nat -> Bool) -> m PruneResult

+ Agda.TypeChecking.MetaVars.Occurs: prune :: (PureTCM m, MonadMetaSolver m) => MetaId -> Args -> (Nat -> Bool) -> m PruneResult

- Agda.TypeChecking.MetaVars.Occurs: rigidVarsNotContainedIn :: (MonadReduce m, MonadAddContext m, MonadTCEnv m, MonadDebug m, AnyRigid a) => a -> (Nat -> Bool) -> m Bool

+ Agda.TypeChecking.MetaVars.Occurs: rigidVarsNotContainedIn :: (PureTCM m, AnyRigid a) => a -> (Nat -> Bool) -> m Bool

- Agda.TypeChecking.Monad.Base: AmbiguousModule :: QName -> NonEmpty ModuleName -> TypeError

+ Agda.TypeChecking.Monad.Base: AmbiguousModule :: QName -> List1 ModuleName -> TypeError

- Agda.TypeChecking.Monad.Base: AmbiguousName :: QName -> NonEmpty QName -> TypeError

+ Agda.TypeChecking.Monad.Base: AmbiguousName :: QName -> List1 QName -> TypeError

- Agda.TypeChecking.Monad.Base: AmbiguousParseForApplication :: [Expr] -> [Expr] -> TypeError

+ Agda.TypeChecking.Monad.Base: AmbiguousParseForApplication :: List2 Expr -> List1 Expr -> TypeError

- Agda.TypeChecking.Monad.Base: Axiom :: Defn

+ Agda.TypeChecking.Monad.Base: Axiom :: Bool -> Defn

- Agda.TypeChecking.Monad.Base: BlockedOnMeta :: TCState -> MetaId -> UnquoteError

+ Agda.TypeChecking.Monad.Base: BlockedOnMeta :: TCState -> Blocker -> UnquoteError

- Agda.TypeChecking.Monad.Base: Candidate :: Term -> Type -> Bool -> Candidate

+ Agda.TypeChecking.Monad.Base: Candidate :: CandidateKind -> Term -> Type -> Bool -> Candidate

- Agda.TypeChecking.Monad.Base: CannotEliminateWithPattern :: NamedArg Pattern -> Type -> TypeError

+ Agda.TypeChecking.Monad.Base: CannotEliminateWithPattern :: Maybe Blocker -> NamedArg Pattern -> Type -> TypeError

- Agda.TypeChecking.Monad.Base: CannotResolveAmbiguousPatternSynonym :: NonEmpty (QName, PatternSynDefn) -> TypeError

+ Agda.TypeChecking.Monad.Base: CannotResolveAmbiguousPatternSynonym :: List1 (QName, PatternSynDefn) -> TypeError

- Agda.TypeChecking.Monad.Base: CantResolveOverloadedConstructorsTargetingSameDatatype :: QName -> [QName] -> TypeError

+ Agda.TypeChecking.Monad.Base: CantResolveOverloadedConstructorsTargetingSameDatatype :: QName -> List1 QName -> TypeError

- Agda.TypeChecking.Monad.Base: CheckArgs :: ExpandHidden -> Range -> [NamedArg Expr] -> Type -> Type -> ([Maybe Range] -> Elims -> Type -> CheckedTarget -> TCM Term) -> TypeCheckingProblem

+ Agda.TypeChecking.Monad.Base: CheckArgs :: Comparison -> ExpandHidden -> Range -> [NamedArg Expr] -> Type -> Type -> (ArgsCheckState CheckedTarget -> TCM Term) -> TypeCheckingProblem

- Agda.TypeChecking.Monad.Base: CheckFunDef :: Delayed -> DefInfo -> QName -> [Clause] -> Constraint

+ Agda.TypeChecking.Monad.Base: CheckFunDef :: Delayed -> DefInfo -> QName -> [Clause] -> TCErr -> Constraint

- Agda.TypeChecking.Monad.Base: CheckFunDefCall :: Range -> QName -> [Clause] -> Call

+ Agda.TypeChecking.Monad.Base: CheckFunDefCall :: Range -> QName -> [Clause] -> Bool -> Call

- Agda.TypeChecking.Monad.Base: CheckLambda :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> Expr -> Type -> TypeCheckingProblem

+ Agda.TypeChecking.Monad.Base: CheckLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> Expr -> Type -> TypeCheckingProblem

- Agda.TypeChecking.Monad.Base: CheckProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> NonEmpty QName -> Args -> Type -> Int -> Term -> Type -> TypeCheckingProblem

+ Agda.TypeChecking.Monad.Base: CheckProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> List1 QName -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TypeCheckingProblem

- Agda.TypeChecking.Monad.Base: ClashingDefinition :: QName -> QName -> TypeError

+ Agda.TypeChecking.Monad.Base: ClashingDefinition :: QName -> QName -> Maybe NiceDeclaration -> TypeError

- Agda.TypeChecking.Monad.Base: EnterSection :: !ModuleInfo -> !ModuleName -> !Telescope -> TypeCheckAction

+ Agda.TypeChecking.Monad.Base: EnterSection :: !ModuleName -> !Telescope -> TypeCheckAction

- Agda.TypeChecking.Monad.Base: ExtLamInfo :: ModuleName -> !Maybe System -> ExtLamInfo

+ Agda.TypeChecking.Monad.Base: ExtLamInfo :: ModuleName -> Bool -> !Maybe System -> ExtLamInfo

- Agda.TypeChecking.Monad.Base: FindInstance :: MetaId -> Maybe MetaId -> Maybe [Candidate] -> Constraint

+ Agda.TypeChecking.Monad.Base: FindInstance :: MetaId -> Maybe [Candidate] -> Constraint

- Agda.TypeChecking.Monad.Base: FixityInRenamingModule :: NonEmpty Range -> Warning

+ Agda.TypeChecking.Monad.Base: FixityInRenamingModule :: List1 Range -> Warning

- Agda.TypeChecking.Monad.Base: Interface :: Hash -> Text -> FileType -> [(ModuleName, Hash)] -> ModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> DisplayForms -> Map QName String -> Maybe String -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface

+ Agda.TypeChecking.Monad.Base: Interface :: Hash -> Text -> FileType -> [(ModuleName, Hash)] -> ModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> DisplayForms -> Map QName Text -> Maybe Text -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface

- Agda.TypeChecking.Monad.Base: MetaInfo :: Closure Range -> RunMetaOccursCheck -> MetaNameSuggestion -> Arg DoGeneralize -> MetaInfo

+ Agda.TypeChecking.Monad.Base: MetaInfo :: Closure Range -> Modality -> RunMetaOccursCheck -> MetaNameSuggestion -> Arg DoGeneralize -> MetaInfo

- Agda.TypeChecking.Monad.Base: ModuleDoesntExport :: QName -> [ImportedName] -> Warning

+ Agda.TypeChecking.Monad.Base: ModuleDoesntExport :: QName -> [Name] -> [Name] -> [ImportedName] -> Warning

- Agda.TypeChecking.Monad.Base: ModuleInfo :: Interface -> Bool -> Bool -> ModuleInfo

+ Agda.TypeChecking.Monad.Base: ModuleInfo :: Interface -> [TCWarning] -> Bool -> ModuleCheckMode -> ModuleInfo

- Agda.TypeChecking.Monad.Base: NoParseForApplication :: [Expr] -> TypeError

+ Agda.TypeChecking.Monad.Base: NoParseForApplication :: List2 Expr -> TypeError

- Agda.TypeChecking.Monad.Base: NoParseForLHS :: LHSOrPatSyn -> Pattern -> TypeError

+ Agda.TypeChecking.Monad.Base: NoParseForLHS :: LHSOrPatSyn -> [Pattern] -> Pattern -> TypeError

- Agda.TypeChecking.Monad.Base: OpenThing :: CheckpointId -> a -> Open a

+ Agda.TypeChecking.Monad.Base: OpenThing :: CheckpointId -> Map CheckpointId Substitution -> ModuleNameHash -> a -> Open a

- Agda.TypeChecking.Monad.Base: PConstr :: Set ProblemId -> Closure Constraint -> ProblemConstraint

+ Agda.TypeChecking.Monad.Base: PConstr :: Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint

- Agda.TypeChecking.Monad.Base: PInf :: NLPSort

+ Agda.TypeChecking.Monad.Base: PInf :: IsFibrant -> Integer -> NLPSort

- Agda.TypeChecking.Monad.Base: PatternErr :: TCErr

+ Agda.TypeChecking.Monad.Base: PatternErr :: Blocker -> TCErr

- Agda.TypeChecking.Monad.Base: PersistentTCSt :: DecodedModules -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState

+ Agda.TypeChecking.Monad.Base: PersistentTCSt :: !DecodedModules -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState

- Agda.TypeChecking.Monad.Base: PostScopeState :: !CompressedFile -> !DisambiguatedNames -> !MetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe ModuleName -> !TempInstanceTable -> !ConcreteNames -> !Map RawName [RawName] -> !Map Name [RawName] -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState

+ Agda.TypeChecking.Monad.Base: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !MetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe ModuleName -> !TempInstanceTable -> !ConcreteNames -> !Map RawName [RawName] -> !Map Name [RawName] -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState

- Agda.TypeChecking.Monad.Base: PostponedTypeCheckingProblem :: Closure TypeCheckingProblem -> TCM Bool -> MetaInstantiation

+ Agda.TypeChecking.Monad.Base: PostponedTypeCheckingProblem :: Closure TypeCheckingProblem -> MetaInstantiation

- Agda.TypeChecking.Monad.Base: PreScopeState :: !CompressedFile -> !Signature -> !Set ModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName String -> !Map QName String -> !Maybe String -> !Set QName -> PreScopeState

+ Agda.TypeChecking.Monad.Base: PreScopeState :: !HighlightingInfo -> !Signature -> !Set ModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName Text -> !Map QName Text -> !Maybe Text -> !Set QName -> !Map FilePath ProjectConfig -> !Map FilePath AgdaLibFile -> PreScopeState

- Agda.TypeChecking.Monad.Base: Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> Maybe Induction -> IsAbstract -> CompKit -> Defn

+ Agda.TypeChecking.Monad.Base: Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> IsAbstract -> CompKit -> Defn

- Agda.TypeChecking.Monad.Base: RewriteRule :: QName -> Telescope -> QName -> PElims -> Term -> Type -> RewriteRule

+ Agda.TypeChecking.Monad.Base: RewriteRule :: QName -> Telescope -> QName -> PElims -> Term -> Type -> Bool -> RewriteRule

- Agda.TypeChecking.Monad.Base: SomeGeneralizableArgs :: Int -> NumGeneralizableArgs

+ Agda.TypeChecking.Monad.Base: SomeGeneralizableArgs :: !Int -> NumGeneralizableArgs

- Agda.TypeChecking.Monad.Base: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> !Int -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Bool -> Maybe BackendName -> TCEnv

+ Agda.TypeChecking.Monad.Base: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> ReduceDefs -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Maybe BackendName -> Bool -> TCEnv

- Agda.TypeChecking.Monad.Base: TCWarning :: Range -> Warning -> Doc -> Bool -> TCWarning

+ Agda.TypeChecking.Monad.Base: TCWarning :: CallStack -> Range -> Warning -> Doc -> Bool -> TCWarning

- Agda.TypeChecking.Monad.Base: TypeError :: TCState -> Closure TypeError -> TCErr

+ Agda.TypeChecking.Monad.Base: TypeError :: CallStack -> TCState -> Closure TypeError -> TCErr

- Agda.TypeChecking.Monad.Base: UnificationStuck :: QName -> Telescope -> Args -> Args -> [UnificationFailure] -> SplitError

+ Agda.TypeChecking.Monad.Base: UnificationStuck :: Maybe Blocker -> QName -> Telescope -> Args -> Args -> [UnificationFailure] -> SplitError

- Agda.TypeChecking.Monad.Base: UnquoteTactic :: Maybe MetaId -> Term -> Term -> Type -> Constraint

+ Agda.TypeChecking.Monad.Base: UnquoteTactic :: Term -> Term -> Type -> Constraint

- Agda.TypeChecking.Monad.Base: UserWarning :: String -> Warning

+ Agda.TypeChecking.Monad.Base: UserWarning :: Text -> Warning

- Agda.TypeChecking.Monad.Base: [iImportWarning] :: Interface -> Maybe String

+ Agda.TypeChecking.Monad.Base: [iImportWarning] :: Interface -> Maybe Text

- Agda.TypeChecking.Monad.Base: [iUserWarnings] :: Interface -> Map QName String

+ Agda.TypeChecking.Monad.Base: [iUserWarnings] :: Interface -> Map QName Text

- Agda.TypeChecking.Monad.Base: [miWarnings] :: ModuleInfo -> Bool

+ Agda.TypeChecking.Monad.Base: [miWarnings] :: ModuleInfo -> [TCWarning]

- Agda.TypeChecking.Monad.Base: [stDecodedModules] :: PersistentTCState -> DecodedModules

+ Agda.TypeChecking.Monad.Base: [stDecodedModules] :: PersistentTCState -> !DecodedModules

- Agda.TypeChecking.Monad.Base: [stPostSyntaxInfo] :: PostScopeState -> !CompressedFile

+ Agda.TypeChecking.Monad.Base: [stPostSyntaxInfo] :: PostScopeState -> !HighlightingInfo

- Agda.TypeChecking.Monad.Base: [stPreImportedUserWarnings] :: PreScopeState -> !Map QName String

+ Agda.TypeChecking.Monad.Base: [stPreImportedUserWarnings] :: PreScopeState -> !Map QName Text

- Agda.TypeChecking.Monad.Base: [stPreLocalUserWarnings] :: PreScopeState -> !Map QName String

+ Agda.TypeChecking.Monad.Base: [stPreLocalUserWarnings] :: PreScopeState -> !Map QName Text

- Agda.TypeChecking.Monad.Base: [stPreTokens] :: PreScopeState -> !CompressedFile

+ Agda.TypeChecking.Monad.Base: [stPreTokens] :: PreScopeState -> !HighlightingInfo

- Agda.TypeChecking.Monad.Base: [stPreWarningOnImport] :: PreScopeState -> !Maybe String

+ Agda.TypeChecking.Monad.Base: [stPreWarningOnImport] :: PreScopeState -> !Maybe Text

- Agda.TypeChecking.Monad.Base: askTC :: MonadTCEnv m => m TCEnv

+ Agda.TypeChecking.Monad.Base: askTC :: (MonadTCEnv m, MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv

- Agda.TypeChecking.Monad.Base: fresh :: MonadFresh i m => m i

+ Agda.TypeChecking.Monad.Base: fresh :: (MonadFresh i m, MonadTrans t, MonadFresh i n, t n ~ m) => m i

- Agda.TypeChecking.Monad.Base: genericDocError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> m a

+ Agda.TypeChecking.Monad.Base: genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a

- Agda.TypeChecking.Monad.Base: genericError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => String -> m a

+ Agda.TypeChecking.Monad.Base: genericError :: (HasCallStack, MonadTCError m) => String -> m a

- Agda.TypeChecking.Monad.Base: getTC :: MonadTCState m => m TCState

+ Agda.TypeChecking.Monad.Base: getTC :: (MonadTCState m, MonadTrans t, MonadTCState n, t n ~ m) => m TCState

- Agda.TypeChecking.Monad.Base: getTCState :: ReadTCState m => m TCState

+ Agda.TypeChecking.Monad.Base: getTCState :: (ReadTCState m, MonadTrans t, ReadTCState n, t n ~ m) => m TCState

- Agda.TypeChecking.Monad.Base: getUserWarnings :: ReadTCState m => m (Map QName String)

+ Agda.TypeChecking.Monad.Base: getUserWarnings :: ReadTCState m => m (Map QName Text)

- Agda.TypeChecking.Monad.Base: ifTopLevelAndHighlightingLevelIs :: MonadTCM tcm => HighlightingLevel -> tcm () -> tcm ()

+ Agda.TypeChecking.Monad.Base: ifTopLevelAndHighlightingLevelIs :: MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()

- Agda.TypeChecking.Monad.Base: ifTopLevelAndHighlightingLevelIsOr :: MonadTCM tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()

+ Agda.TypeChecking.Monad.Base: ifTopLevelAndHighlightingLevelIsOr :: MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()

- Agda.TypeChecking.Monad.Base: internalError :: MonadTCM tcm => String -> tcm a

+ Agda.TypeChecking.Monad.Base: internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a

- Agda.TypeChecking.Monad.Base: liftReduce :: MonadReduce m => ReduceM a -> m a

+ Agda.TypeChecking.Monad.Base: liftReduce :: (MonadReduce m, MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a

- Agda.TypeChecking.Monad.Base: localTC :: MonadTCEnv m => (TCEnv -> TCEnv) -> m a -> m a

+ Agda.TypeChecking.Monad.Base: localTC :: (MonadTCEnv m, MonadTransControl t, MonadTCEnv n, t n ~ m) => (TCEnv -> TCEnv) -> m a -> m a

- Agda.TypeChecking.Monad.Base: locallyTCState :: ReadTCState m => Lens' a TCState -> (a -> a) -> m b -> m b

+ Agda.TypeChecking.Monad.Base: locallyTCState :: (ReadTCState m, MonadTransControl t, ReadTCState n, t n ~ m) => Lens' a TCState -> (a -> a) -> m b -> m b

- Agda.TypeChecking.Monad.Base: modifyTC :: MonadTCState m => (TCState -> TCState) -> m ()

+ Agda.TypeChecking.Monad.Base: modifyTC :: (MonadTCState m, MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()

- Agda.TypeChecking.Monad.Base: patternViolation :: MonadError TCErr m => m a

+ Agda.TypeChecking.Monad.Base: patternViolation :: (MonadBlock m, MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a

- Agda.TypeChecking.Monad.Base: putTC :: MonadTCState m => TCState -> m ()

+ Agda.TypeChecking.Monad.Base: putTC :: (MonadTCState m, MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()

- Agda.TypeChecking.Monad.Base: stImportedUserWarnings :: Lens' (Map QName String) TCState

+ Agda.TypeChecking.Monad.Base: stImportedUserWarnings :: Lens' (Map QName Text) TCState

- Agda.TypeChecking.Monad.Base: stLocalUserWarnings :: Lens' (Map QName String) TCState

+ Agda.TypeChecking.Monad.Base: stLocalUserWarnings :: Lens' (Map QName Text) TCState

- Agda.TypeChecking.Monad.Base: stSyntaxInfo :: Lens' CompressedFile TCState

+ Agda.TypeChecking.Monad.Base: stSyntaxInfo :: Lens' HighlightingInfo TCState

- Agda.TypeChecking.Monad.Base: stTokens :: Lens' CompressedFile TCState

+ Agda.TypeChecking.Monad.Base: stTokens :: Lens' HighlightingInfo TCState

- Agda.TypeChecking.Monad.Base: stWarningOnImport :: Lens' (Maybe String) TCState

+ Agda.TypeChecking.Monad.Base: stWarningOnImport :: Lens' (Maybe Text) TCState

- Agda.TypeChecking.Monad.Base: type DecodedModules = Map TopLevelModuleName Interface

+ Agda.TypeChecking.Monad.Base: type DecodedModules = Map TopLevelModuleName ModuleInfo

- Agda.TypeChecking.Monad.Base: type DisambiguatedNames = IntMap QName

+ Agda.TypeChecking.Monad.Base: type DisambiguatedNames = IntMap DisambiguatedName

- Agda.TypeChecking.Monad.Base: type InteractionPoints = Map InteractionId InteractionPoint

+ Agda.TypeChecking.Monad.Base: type InteractionPoints = BiMap InteractionId InteractionPoint

- Agda.TypeChecking.Monad.Base: typeError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => TypeError -> m a

+ Agda.TypeChecking.Monad.Base: typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a

- Agda.TypeChecking.Monad.Base: typeError_ :: (MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr

+ Agda.TypeChecking.Monad.Base: typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr

- Agda.TypeChecking.Monad.Benchmark: billPureTo :: MonadBench a m => Account a -> c -> m c

+ Agda.TypeChecking.Monad.Benchmark: billPureTo :: MonadBench m => Account (BenchPhase m) -> c -> m c

- Agda.TypeChecking.Monad.Benchmark: billTo :: MonadBench a m => Account a -> m c -> m c

+ Agda.TypeChecking.Monad.Benchmark: billTo :: MonadBench m => Account (BenchPhase m) -> m c -> m c

- Agda.TypeChecking.Monad.Benchmark: billToCPS :: MonadBench a m => Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c

+ Agda.TypeChecking.Monad.Benchmark: billToCPS :: MonadBench m => Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c

- Agda.TypeChecking.Monad.Benchmark: class (Ord a, Functor m, MonadIO m) => MonadBench a m | m -> a

+ Agda.TypeChecking.Monad.Benchmark: class (Ord (BenchPhase m), Functor m, MonadIO m) => MonadBench m

- Agda.TypeChecking.Monad.Benchmark: getBenchmark :: MonadBench a m => m (Benchmark a)

+ Agda.TypeChecking.Monad.Benchmark: getBenchmark :: MonadBench m => m (Benchmark (BenchPhase m))

- Agda.TypeChecking.Monad.Benchmark: reset :: MonadBench a m => m ()

+ Agda.TypeChecking.Monad.Benchmark: reset :: MonadBench m => m ()

- Agda.TypeChecking.Monad.Builtin: constructorForm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => Term -> m Term

+ Agda.TypeChecking.Monad.Builtin: constructorForm :: HasBuiltins m => Term -> m Term

- Agda.TypeChecking.Monad.Builtin: getBuiltinThing :: HasBuiltins m => String -> m (Maybe (Builtin PrimFun))

+ Agda.TypeChecking.Monad.Builtin: getBuiltinThing :: (HasBuiltins m, MonadTrans t, HasBuiltins n, t n ~ m) => String -> m (Maybe (Builtin PrimFun))

- Agda.TypeChecking.Monad.Caching: cachingStarts :: (MonadTCState m, ReadTCState m) => m ()

+ Agda.TypeChecking.Monad.Caching: cachingStarts :: (MonadDebug m, MonadTCState m, ReadTCState m) => m ()

- Agda.TypeChecking.Monad.Constraints: addAwakeConstraint :: MonadConstraint m => Constraint -> m ()

+ Agda.TypeChecking.Monad.Constraints: addAwakeConstraint :: MonadConstraint m => Blocker -> Constraint -> m ()

- Agda.TypeChecking.Monad.Constraints: addAwakeConstraint' :: Constraint -> TCM ()

+ Agda.TypeChecking.Monad.Constraints: addAwakeConstraint' :: Blocker -> Constraint -> TCM ()

- Agda.TypeChecking.Monad.Constraints: addConstraint :: MonadConstraint m => Constraint -> m ()

+ Agda.TypeChecking.Monad.Constraints: addConstraint :: MonadConstraint m => Blocker -> Constraint -> m ()

- Agda.TypeChecking.Monad.Constraints: addConstraint' :: Constraint -> TCM ()

+ Agda.TypeChecking.Monad.Constraints: addConstraint' :: Blocker -> Constraint -> TCM ()

- Agda.TypeChecking.Monad.Constraints: addConstraintTo :: Lens' Constraints TCState -> Constraint -> TCM ()

+ Agda.TypeChecking.Monad.Constraints: addConstraintTo :: Lens' Constraints TCState -> Blocker -> Constraint -> TCM ()

- Agda.TypeChecking.Monad.Constraints: buildConstraint :: Constraint -> TCM ProblemConstraint

+ Agda.TypeChecking.Monad.Constraints: buildConstraint :: Blocker -> Constraint -> TCM ProblemConstraint

- Agda.TypeChecking.Monad.Constraints: buildProblemConstraint :: (MonadTCEnv m, ReadTCState m) => Set ProblemId -> Constraint -> m ProblemConstraint

+ Agda.TypeChecking.Monad.Constraints: buildProblemConstraint :: (MonadTCEnv m, ReadTCState m) => Set ProblemId -> Blocker -> Constraint -> m ProblemConstraint

- Agda.TypeChecking.Monad.Constraints: buildProblemConstraint_ :: (MonadTCEnv m, ReadTCState m) => Constraint -> m ProblemConstraint

+ Agda.TypeChecking.Monad.Constraints: buildProblemConstraint_ :: (MonadTCEnv m, ReadTCState m) => Blocker -> Constraint -> m ProblemConstraint

- Agda.TypeChecking.Monad.Constraints: class (MonadTCEnv m, ReadTCState m, MonadError TCErr m, HasOptions m, MonadDebug m) => MonadConstraint m

+ Agda.TypeChecking.Monad.Constraints: class (MonadTCEnv m, ReadTCState m, MonadError TCErr m, MonadBlock m, HasOptions m, MonadDebug m) => MonadConstraint m

- Agda.TypeChecking.Monad.Constraints: wakeConstraints :: MonadConstraint m => (ProblemConstraint -> m Bool) -> m ()

+ Agda.TypeChecking.Monad.Constraints: wakeConstraints :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m ()

- Agda.TypeChecking.Monad.Context: addCtx :: MonadAddContext m => Name -> Dom Type -> m a -> m a

+ Agda.TypeChecking.Monad.Context: addCtx :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Name -> Dom Type -> m a -> m a

- Agda.TypeChecking.Monad.Context: addLetBinding' :: MonadAddContext m => Name -> Term -> Dom Type -> m a -> m a

+ Agda.TypeChecking.Monad.Context: addLetBinding' :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Name -> Term -> Dom Type -> m a -> m a

- Agda.TypeChecking.Monad.Context: defaultAddLetBinding' :: MonadTCEnv m => Name -> Term -> Dom Type -> m a -> m a

+ Agda.TypeChecking.Monad.Context: defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Name -> Term -> Dom Type -> m a -> m a

- Agda.TypeChecking.Monad.Context: escapeContext :: MonadAddContext m => Empty -> Int -> m a -> m a

+ Agda.TypeChecking.Monad.Context: escapeContext :: MonadAddContext m => Impossible -> Int -> m a -> m a

- Agda.TypeChecking.Monad.Context: mapAbstraction :: (Subst t a, Subst t' b, Free b, MonadAddContext m) => Dom Type -> (a -> m b) -> Abs a -> m (Abs b)

+ 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: underAbstraction :: (Subst t a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.TypeChecking.Monad.Context: underAbstraction :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.TypeChecking.Monad.Context: underAbstraction' :: (Subst t a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.TypeChecking.Monad.Context: underAbstraction' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.TypeChecking.Monad.Context: underAbstractionAbs :: (Subst t a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.TypeChecking.Monad.Context: underAbstractionAbs :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.TypeChecking.Monad.Context: underAbstractionAbs' :: (Subst t a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

+ Agda.TypeChecking.Monad.Context: underAbstractionAbs' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b

- Agda.TypeChecking.Monad.Context: underAbstraction_ :: (Subst t a, MonadAddContext m) => Abs a -> (a -> m b) -> m b

+ Agda.TypeChecking.Monad.Context: underAbstraction_ :: (Subst a, MonadAddContext m) => Abs a -> (a -> m b) -> m b

- Agda.TypeChecking.Monad.Context: updateContext :: MonadAddContext m => Substitution -> (Context -> Context) -> m a -> m a

+ Agda.TypeChecking.Monad.Context: updateContext :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Substitution -> (Context -> Context) -> m a -> m a

- Agda.TypeChecking.Monad.Context: withFreshName :: MonadAddContext m => Range -> ArgName -> (Name -> m a) -> m a

+ Agda.TypeChecking.Monad.Context: withFreshName :: (MonadAddContext m, MonadAddContext n, MonadTransControl t, t n ~ m) => Range -> ArgName -> (Name -> m a) -> m a

- Agda.TypeChecking.Monad.Debug: formatDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m String

+ Agda.TypeChecking.Monad.Debug: formatDebugMessage :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> TCM Doc -> m String

- Agda.TypeChecking.Monad.Debug: getVerbosity :: (MonadDebug m, HasOptions m) => m Verbosity

+ Agda.TypeChecking.Monad.Debug: getVerbosity :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => m Verbosity

- Agda.TypeChecking.Monad.Debug: isDebugPrinting :: (MonadDebug m, MonadTCEnv m) => m Bool

+ Agda.TypeChecking.Monad.Debug: isDebugPrinting :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => m Bool

- Agda.TypeChecking.Monad.Debug: nowDebugPrinting :: (MonadDebug m, MonadTCEnv m) => m a -> m a

+ Agda.TypeChecking.Monad.Debug: nowDebugPrinting :: (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => m a -> m a

- Agda.TypeChecking.Monad.Debug: traceDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a

+ Agda.TypeChecking.Monad.Debug: traceDebugMessage :: (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> String -> m a -> m a

- Agda.TypeChecking.Monad.Debug: verboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a

+ Agda.TypeChecking.Monad.Debug: verboseBracket :: (MonadDebug m, MonadTransControl t, MonadDebug n, m ~ t n) => VerboseKey -> VerboseLevel -> String -> m a -> m a

- Agda.TypeChecking.Monad.Imports: getDecodedModule :: TopLevelModuleName -> TCM (Maybe Interface)

+ Agda.TypeChecking.Monad.Imports: getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)

- Agda.TypeChecking.Monad.Imports: getVisitedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)

+ Agda.TypeChecking.Monad.Imports: getVisitedModule :: ReadTCState m => TopLevelModuleName -> m (Maybe ModuleInfo)

- Agda.TypeChecking.Monad.Imports: getVisitedModules :: TCM VisitedModules

+ Agda.TypeChecking.Monad.Imports: getVisitedModules :: ReadTCState m => m VisitedModules

- Agda.TypeChecking.Monad.Imports: storeDecodedModule :: Interface -> TCM ()

+ Agda.TypeChecking.Monad.Imports: storeDecodedModule :: ModuleInfo -> TCM ()

- Agda.TypeChecking.Monad.MetaVars: freshInteractionId :: MonadInteractionPoints m => m InteractionId

+ Agda.TypeChecking.Monad.MetaVars: freshInteractionId :: (MonadInteractionPoints m, MonadTrans t, MonadInteractionPoints n, t n ~ m) => m InteractionId

- Agda.TypeChecking.Monad.MetaVars: getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m) => MetaId -> m Type

+ Agda.TypeChecking.Monad.MetaVars: getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m) => MetaId -> m Type

- Agda.TypeChecking.Monad.MetaVars: modifyInteractionPoints :: MonadInteractionPoints m => (InteractionPoints -> InteractionPoints) -> m ()

+ Agda.TypeChecking.Monad.MetaVars: modifyInteractionPoints :: (MonadInteractionPoints m, MonadTrans t, MonadInteractionPoints n, t n ~ m) => (InteractionPoints -> InteractionPoints) -> m ()

- Agda.TypeChecking.Monad.Open: getOpen :: (Subst Term a, MonadTCEnv m) => Open a -> m a

+ Agda.TypeChecking.Monad.Open: getOpen :: (TermSubst a, MonadTCEnv m) => Open a -> m a

- Agda.TypeChecking.Monad.Open: makeOpen :: MonadTCEnv m => a -> m (Open a)

+ Agda.TypeChecking.Monad.Open: makeOpen :: (ReadTCState m, MonadTCEnv m) => a -> m (Open a)

- Agda.TypeChecking.Monad.Open: tryGetOpen :: (Subst Term a, MonadTCEnv m) => Open a -> m (Maybe a)

+ Agda.TypeChecking.Monad.Open: tryGetOpen :: (TermSubst a, ReadTCState m, MonadTCEnv m) => (Substitution -> a -> Maybe a) -> Open a -> m (Maybe a)

- Agda.TypeChecking.Monad.Signature: defaultGetRewriteRulesFor :: Monad m => m TCState -> QName -> m RewriteRules

+ Agda.TypeChecking.Monad.Signature: defaultGetRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m RewriteRules

- Agda.TypeChecking.Monad.Signature: getCompiled :: QName -> TCM (Maybe Compiled)

+ Agda.TypeChecking.Monad.Signature: getCompiled :: HasConstInfo m => QName -> m (Maybe Compiled)

- Agda.TypeChecking.Monad.Signature: getCompiledArgUse :: QName -> TCM [Bool]

+ Agda.TypeChecking.Monad.Signature: getCompiledArgUse :: HasConstInfo m => QName -> m (Maybe [ArgUsage])

- Agda.TypeChecking.Monad.Signature: getErasedConArgs :: QName -> TCM [Bool]

+ Agda.TypeChecking.Monad.Signature: getErasedConArgs :: HasConstInfo m => QName -> m [Bool]

- Agda.TypeChecking.Monad.Signature: getTreeless :: QName -> TCM (Maybe TTerm)

+ Agda.TypeChecking.Monad.Signature: getTreeless :: HasConstInfo m => QName -> m (Maybe TTerm)

- Agda.TypeChecking.Monad.Signature: modifyArgOccurrences :: QName -> ([Occurrence] -> [Occurrence]) -> TCM ()

+ Agda.TypeChecking.Monad.Signature: modifyArgOccurrences :: MonadTCState m => QName -> ([Occurrence] -> [Occurrence]) -> m ()

- Agda.TypeChecking.Monad.Signature: setArgOccurrences :: QName -> [Occurrence] -> TCM ()

+ Agda.TypeChecking.Monad.Signature: setArgOccurrences :: MonadTCState m => QName -> [Occurrence] -> m ()

- Agda.TypeChecking.Monad.Signature: setCompiledArgUse :: QName -> [Bool] -> TCM ()

+ Agda.TypeChecking.Monad.Signature: setCompiledArgUse :: QName -> [ArgUsage] -> TCM ()

- Agda.TypeChecking.Monad.Signature: setPolarity :: QName -> [Polarity] -> TCM ()

+ Agda.TypeChecking.Monad.Signature: setPolarity :: (MonadTCState m, MonadDebug m) => QName -> [Polarity] -> m ()

- Agda.TypeChecking.Monad.SizedTypes: DSizeVar :: Nat -> Offset -> DeepSizeView

+ Agda.TypeChecking.Monad.SizedTypes: DSizeVar :: ProjectedVar -> Offset -> DeepSizeView

- Agda.TypeChecking.Monad.SizedTypes: sizeView :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => Term -> m SizeView

+ Agda.TypeChecking.Monad.SizedTypes: sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => Term -> m SizeView

- Agda.TypeChecking.Monad.State: getInteractionOutputCallback :: TCM InteractionOutputCallback

+ Agda.TypeChecking.Monad.State: getInteractionOutputCallback :: ReadTCState m => m InteractionOutputCallback

- Agda.TypeChecking.Monad.State: modifyGlobalDefinition :: QName -> (Definition -> Definition) -> TCM ()

+ Agda.TypeChecking.Monad.State: modifyGlobalDefinition :: MonadTCState m => QName -> (Definition -> Definition) -> m ()

- Agda.TypeChecking.Monad.State: modifyImportedSignature :: (Signature -> Signature) -> TCM ()

+ Agda.TypeChecking.Monad.State: modifyImportedSignature :: MonadTCState m => (Signature -> Signature) -> m ()

- Agda.TypeChecking.Monad.State: modifySignature :: (Signature -> Signature) -> TCM ()

+ Agda.TypeChecking.Monad.State: modifySignature :: MonadTCState m => (Signature -> Signature) -> m ()

- Agda.TypeChecking.Monad.State: setSignature :: Signature -> TCM ()

+ Agda.TypeChecking.Monad.State: setSignature :: MonadTCState m => Signature -> m ()

- Agda.TypeChecking.Monad.State: withSignature :: Signature -> TCM a -> TCM a

+ Agda.TypeChecking.Monad.State: withSignature :: (ReadTCState m, MonadTCState m) => Signature -> m a -> m a

- Agda.TypeChecking.Monad.Trace: highlightAsTypeChecked :: (MonadTCM tcm, ReadTCState tcm) => Range -> Range -> tcm a -> tcm a

+ Agda.TypeChecking.Monad.Trace: highlightAsTypeChecked :: MonadTrace m => Range -> Range -> m a -> m a

- Agda.TypeChecking.Monad.Trace: printHighlightingInfo :: (MonadTCM tcm, ReadTCState tcm) => RemoveTokenBasedHighlighting -> HighlightingInfo -> tcm ()

+ Agda.TypeChecking.Monad.Trace: printHighlightingInfo :: (MonadTrace m, MonadTrans t, MonadTrace n, t n ~ m) => RemoveTokenBasedHighlighting -> HighlightingInfo -> m ()

- Agda.TypeChecking.Monad.Trace: setCurrentRange :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) => x -> tcm a -> tcm a

+ Agda.TypeChecking.Monad.Trace: setCurrentRange :: (MonadTrace m, HasRange x) => x -> m a -> m a

- Agda.TypeChecking.Monad.Trace: traceCall :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Call -> tcm a -> tcm a

+ Agda.TypeChecking.Monad.Trace: traceCall :: MonadTrace m => Call -> m a -> m a

- Agda.TypeChecking.Monad.Trace: traceCallCPS :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Call -> ((a -> tcm b) -> tcm b) -> (a -> tcm b) -> tcm b

+ Agda.TypeChecking.Monad.Trace: traceCallCPS :: MonadTrace m => Call -> ((a -> m b) -> m b) -> (a -> m b) -> m b

- Agda.TypeChecking.Monad.Trace: traceCallM :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => tcm Call -> tcm a -> tcm a

+ Agda.TypeChecking.Monad.Trace: traceCallM :: MonadTrace m => m Call -> m a -> m a

- Agda.TypeChecking.Monad.Trace: traceClosureCall :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Closure Call -> tcm a -> tcm a

+ Agda.TypeChecking.Monad.Trace: traceClosureCall :: MonadTrace m => Closure Call -> m a -> m a

- Agda.TypeChecking.Names: bind :: (MonadFail m, Subst t' b, DeBruijn b, Subst t a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)

+ Agda.TypeChecking.Names: bind :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)

- Agda.TypeChecking.Names: bind' :: (MonadFail m, Subst t' b, DeBruijn b, Subst t a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a

+ Agda.TypeChecking.Names: bind' :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a

- Agda.TypeChecking.Names: inCxt :: (MonadFail m, Subst t a) => Names -> a -> NamesT m a

+ Agda.TypeChecking.Names: inCxt :: (MonadFail m, Subst a) => Names -> a -> NamesT m a

- Agda.TypeChecking.Names: open :: (MonadFail m, Subst t a) => a -> NamesT m (NamesT m a)

+ Agda.TypeChecking.Names: open :: (MonadFail m, Subst a) => a -> NamesT m (NamesT m a)

- Agda.TypeChecking.Patterns.Abstract: expandLitPattern :: Pattern -> TCM Pattern

+ Agda.TypeChecking.Patterns.Abstract: expandLitPattern :: (MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m) => Pattern -> m Pattern

- Agda.TypeChecking.Patterns.Match: buildSubstitution :: DeBruijn a => Empty -> Int -> IntMap (Arg a) -> Substitution' a

+ Agda.TypeChecking.Patterns.Match: buildSubstitution :: DeBruijn a => Impossible -> Int -> IntMap (Arg a) -> Substitution' a

- Agda.TypeChecking.Patterns.Match: foldMatch :: forall p v. IsProjP p => (p -> v -> ReduceM (Match Term, v)) -> [p] -> [v] -> ReduceM (Match Term, [v])

+ Agda.TypeChecking.Patterns.Match: foldMatch :: forall m p v. (IsProjP p, MonadMatch m) => (p -> v -> m (Match Term, v)) -> [p] -> [v] -> m (Match Term, [v])

- Agda.TypeChecking.Patterns.Match: matchCopattern :: DeBruijnPattern -> Elim -> ReduceM (Match Term, Elim)

+ Agda.TypeChecking.Patterns.Match: matchCopattern :: MonadMatch m => DeBruijnPattern -> Elim -> m (Match Term, Elim)

- Agda.TypeChecking.Patterns.Match: matchCopatterns :: [NamedArg DeBruijnPattern] -> [Elim] -> ReduceM (Match Term, [Elim])

+ Agda.TypeChecking.Patterns.Match: matchCopatterns :: MonadMatch m => [NamedArg DeBruijnPattern] -> [Elim] -> m (Match Term, [Elim])

- Agda.TypeChecking.Patterns.Match: matchPattern :: DeBruijnPattern -> Arg Term -> ReduceM (Match Term, Arg Term)

+ Agda.TypeChecking.Patterns.Match: matchPattern :: MonadMatch m => DeBruijnPattern -> Arg Term -> m (Match Term, Arg Term)

- Agda.TypeChecking.Patterns.Match: matchPatternP :: DeBruijnPattern -> Arg DeBruijnPattern -> ReduceM (Match DeBruijnPattern)

+ Agda.TypeChecking.Patterns.Match: matchPatternP :: MonadMatch m => DeBruijnPattern -> Arg DeBruijnPattern -> m (Match DeBruijnPattern)

- Agda.TypeChecking.Patterns.Match: matchPatterns :: [NamedArg DeBruijnPattern] -> [Arg Term] -> ReduceM (Match Term, [Arg Term])

+ Agda.TypeChecking.Patterns.Match: matchPatterns :: MonadMatch m => [NamedArg DeBruijnPattern] -> [Arg Term] -> m (Match Term, [Arg Term])

- Agda.TypeChecking.Patterns.Match: matchPatternsP :: [NamedArg DeBruijnPattern] -> [Arg DeBruijnPattern] -> ReduceM (Match DeBruijnPattern)

+ Agda.TypeChecking.Patterns.Match: matchPatternsP :: MonadMatch m => [NamedArg DeBruijnPattern] -> [Arg DeBruijnPattern] -> m (Match DeBruijnPattern)

- Agda.TypeChecking.Polarity: computePolarity :: [QName] -> TCM ()

+ 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.Pretty: colon :: Monad m => m Doc

+ Agda.TypeChecking.Pretty: colon :: Applicative m => m Doc

- Agda.TypeChecking.Pretty: comma :: Monad m => m Doc

+ Agda.TypeChecking.Pretty: comma :: Applicative m => m Doc

- Agda.TypeChecking.Pretty: equals :: Monad m => m Doc

+ Agda.TypeChecking.Pretty: equals :: Applicative m => m Doc

- Agda.TypeChecking.Pretty: fsep :: Monad m => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: fsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty: fwords :: Monad m => String -> m Doc

+ Agda.TypeChecking.Pretty: fwords :: Applicative m => String -> m Doc

- Agda.TypeChecking.Pretty: hcat :: Monad m => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: hcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty: hsep :: Monad m => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: hsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty: multiLineText :: Monad m => String -> m Doc

+ Agda.TypeChecking.Pretty: multiLineText :: Applicative m => String -> m Doc

- Agda.TypeChecking.Pretty: pretty :: (Monad m, Pretty a) => a -> m Doc

+ Agda.TypeChecking.Pretty: pretty :: (Applicative m, Pretty a) => a -> m Doc

- Agda.TypeChecking.Pretty: prettyA :: (Pretty c, ToConcrete a c, MonadAbsToCon m) => a -> m Doc

+ Agda.TypeChecking.Pretty: prettyA :: (ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc

- Agda.TypeChecking.Pretty: prettyAs :: (Pretty c, ToConcrete a [c], MonadAbsToCon m) => a -> m Doc

+ Agda.TypeChecking.Pretty: prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], Pretty ce, MonadAbsToCon m) => a -> m Doc

- Agda.TypeChecking.Pretty: prettyList :: (Monad m, Semigroup (m Doc)) => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: prettyList :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty: prettyList_ :: (Monad m, Semigroup (m Doc)) => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: prettyList_ :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty: prettyR :: (ToAbstract r a, PrettyTCM a, MonadPretty m, MonadError TCErr m) => r -> m Doc

+ Agda.TypeChecking.Pretty: prettyR :: (ToAbstract r, PrettyTCM (AbsOfRef r), MonadPretty m, MonadError TCErr m) => r -> m Doc

- Agda.TypeChecking.Pretty: punctuate :: (Applicative m, Semigroup (m Doc)) => m Doc -> [m Doc] -> [m Doc]

+ Agda.TypeChecking.Pretty: punctuate :: (Applicative m, Semigroup (m Doc), Foldable t) => m Doc -> t (m Doc) -> [m Doc]

- Agda.TypeChecking.Pretty: pwords :: Monad m => String -> [m Doc]

+ Agda.TypeChecking.Pretty: pwords :: Applicative m => String -> [m Doc]

- Agda.TypeChecking.Pretty: sep :: Monad m => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: sep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty: text :: Monad m => String -> m Doc

+ Agda.TypeChecking.Pretty: text :: Applicative m => String -> m Doc

- Agda.TypeChecking.Pretty: vcat :: Monad m => [m Doc] -> m Doc

+ Agda.TypeChecking.Pretty: vcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc

- Agda.TypeChecking.Pretty.Warning: applyFlagsToTCWarnings :: [TCWarning] -> TCM [TCWarning]

+ Agda.TypeChecking.Pretty.Warning: applyFlagsToTCWarnings :: HasOptions m => [TCWarning] -> m [TCWarning]

- Agda.TypeChecking.Pretty.Warning: tcWarningsToError :: [TCWarning] -> TCM a

+ Agda.TypeChecking.Pretty.Warning: tcWarningsToError :: [TCWarning] -> TCM ()

- Agda.TypeChecking.Primitive: class PrimTerm a

+ Agda.TypeChecking.Primitive: class PrimType a => PrimTerm a

- Agda.TypeChecking.Primitive: mkPrimFun1TCM :: (FromTerm a, ToTerm b, TermLike b) => TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl

+ Agda.TypeChecking.Primitive: mkPrimFun1TCM :: (FromTerm a, ToTerm b) => TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl

- Agda.TypeChecking.Primitive: mkPrimSetOmega :: TCM PrimitiveImpl

+ Agda.TypeChecking.Primitive: mkPrimSetOmega :: IsFibrant -> TCM PrimitiveImpl

- Agda.TypeChecking.Primitive: primType :: PrimType a => a -> TCM Type

+ Agda.TypeChecking.Primitive: primType :: (PrimType a, PrimTerm a) => a -> TCM Type

- Agda.TypeChecking.Primitive.Base: (-->) :: Monad tcm => tcm Type -> tcm Type -> tcm Type

+ Agda.TypeChecking.Primitive.Base: (-->) :: Applicative m => m Type -> m Type -> m Type

- Agda.TypeChecking.Primitive.Base: (.-->) :: Monad tcm => tcm Type -> tcm Type -> tcm Type

+ Agda.TypeChecking.Primitive.Base: (.-->) :: Applicative m => m Type -> m Type -> m Type

- Agda.TypeChecking.Primitive.Base: (..-->) :: Monad tcm => tcm Type -> tcm Type -> tcm Type

+ Agda.TypeChecking.Primitive.Base: (..-->) :: Applicative m => m Type -> m Type -> m Type

- Agda.TypeChecking.Primitive.Base: (<#>) :: Monad tcm => tcm Term -> tcm Term -> tcm Term

+ Agda.TypeChecking.Primitive.Base: (<#>) :: Applicative m => m Term -> m Term -> m Term

- Agda.TypeChecking.Primitive.Base: (<..>) :: Monad tcm => tcm Term -> tcm Term -> tcm Term

+ Agda.TypeChecking.Primitive.Base: (<..>) :: Applicative m => m Term -> m Term -> m Term

- Agda.TypeChecking.Primitive.Base: (<@>) :: Monad tcm => tcm Term -> tcm Term -> tcm Term

+ Agda.TypeChecking.Primitive.Base: (<@>) :: Applicative m => m Term -> m Term -> m Term

- Agda.TypeChecking.Primitive.Base: (<@@>) :: Monad tcm => tcm Term -> (tcm Term, tcm Term, tcm Term) -> tcm Term

+ Agda.TypeChecking.Primitive.Base: (<@@>) :: Applicative m => m Term -> (m Term, m Term, m Term) -> m Term

- Agda.TypeChecking.Primitive.Base: el :: Functor tcm => tcm Term -> tcm Type

+ Agda.TypeChecking.Primitive.Base: el :: Functor m => m Term -> m Type

- Agda.TypeChecking.Primitive.Base: el' :: Monad m => m Term -> m Term -> m Type

+ Agda.TypeChecking.Primitive.Base: el' :: Applicative m => m Term -> m Term -> m Type

- Agda.TypeChecking.Primitive.Base: gApply :: Monad tcm => Hiding -> tcm Term -> tcm Term -> tcm Term

+ Agda.TypeChecking.Primitive.Base: gApply :: Applicative m => Hiding -> m Term -> m Term -> m Term

- Agda.TypeChecking.Primitive.Base: gApply' :: Monad tcm => ArgInfo -> tcm Term -> tcm Term -> tcm Term

+ Agda.TypeChecking.Primitive.Base: gApply' :: Applicative m => ArgInfo -> m Term -> m Term -> m Term

- Agda.TypeChecking.Primitive.Base: garr :: Monad m => (Relevance -> Relevance) -> 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: getBuiltinName :: String -> TCM (Maybe QName)

+ Agda.TypeChecking.Primitive.Base: getBuiltinName :: (HasBuiltins m, MonadReduce m) => String -> m (Maybe QName)

- Agda.TypeChecking.Primitive.Base: isBuiltin :: QName -> String -> TCM Bool

+ Agda.TypeChecking.Primitive.Base: isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> String -> m Bool

- Agda.TypeChecking.Primitive.Base: tSizeUniv :: Monad tcm => tcm Type

+ Agda.TypeChecking.Primitive.Base: tSizeUniv :: Applicative m => m Type

- Agda.TypeChecking.Primitive.Base: tset :: Monad tcm => tcm Type

+ Agda.TypeChecking.Primitive.Base: tset :: Applicative m => m Type

- Agda.TypeChecking.Primitive.Base: varM :: Monad tcm => Int -> tcm Term

+ Agda.TypeChecking.Primitive.Base: varM :: Applicative m => Int -> m Term

- Agda.TypeChecking.Primitive.Cubical: compGlue :: (MonadReduce m, HasConstInfo m, HasBuiltins m) => TranspOrHComp -> Arg Term -> Maybe (Arg Term) -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)

+ Agda.TypeChecking.Primitive.Cubical: compGlue :: PureTCM m => TranspOrHComp -> Arg Term -> Maybe (Arg Term) -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)

- Agda.TypeChecking.Primitive.Cubical: compHCompU :: (MonadReduce m, HasConstInfo m, HasBuiltins m) => TranspOrHComp -> Arg Term -> Maybe (Arg Term) -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)

+ Agda.TypeChecking.Primitive.Cubical: compHCompU :: PureTCM m => TranspOrHComp -> Arg Term -> Maybe (Arg Term) -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)

- Agda.TypeChecking.Primitive.Cubical: headStop :: (HasBuiltins m, MonadReduce m) => TermPosition -> m Term -> m Bool

+ Agda.TypeChecking.Primitive.Cubical: headStop :: PureTCM m => TermPosition -> m Term -> m Bool

- Agda.TypeChecking.Primitive.Cubical: requireCubical :: TCM ()

+ Agda.TypeChecking.Primitive.Cubical: requireCubical :: String -> TCM ()

- Agda.TypeChecking.Primitive.Cubical: unglueTranspGlue :: (HasConstInfo m, MonadReduce m, HasBuiltins m) => Arg Term -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> m Term

+ Agda.TypeChecking.Primitive.Cubical: unglueTranspGlue :: PureTCM m => Arg Term -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> m Term

- Agda.TypeChecking.ProjectionLike: elimView :: (MonadReduce m, MonadTCEnv m, HasConstInfo m) => Bool -> Term -> m Term

+ Agda.TypeChecking.ProjectionLike: elimView :: PureTCM m => ProjEliminator -> Term -> m Term

- Agda.TypeChecking.ProjectionLike: reduceProjectionLike :: (MonadReduce m, MonadTCEnv m, HasConstInfo m) => Term -> m Term

+ Agda.TypeChecking.ProjectionLike: reduceProjectionLike :: PureTCM m => Term -> m Term

- Agda.TypeChecking.Quote: QuotingKit :: (Term -> ReduceM Term) -> (Type -> ReduceM Term) -> (Clause -> ReduceM Term) -> (Dom Type -> ReduceM Term) -> (Definition -> ReduceM Term) -> (forall a. (a -> ReduceM Term) -> [a] -> ReduceM Term) -> QuotingKit

+ Agda.TypeChecking.Quote: QuotingKit :: (Term -> ReduceM Term) -> (Type -> ReduceM Term) -> (Dom Type -> ReduceM Term) -> (Definition -> ReduceM Term) -> (forall a. (a -> ReduceM Term) -> [a] -> ReduceM Term) -> QuotingKit

- Agda.TypeChecking.Records: etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m) => QName -> Args -> Term -> m (Telescope, Args)

+ Agda.TypeChecking.Records: etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m) => QName -> Args -> Term -> m (Telescope, Args)

- Agda.TypeChecking.Records: etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m) => Bool -> QName -> Args -> Term -> m (Telescope, Args)

+ Agda.TypeChecking.Records: etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m) => Bool -> QName -> Args -> Term -> m (Telescope, Args)

- Agda.TypeChecking.Records: getDefType :: (HasConstInfo m, MonadReduce m, MonadDebug m) => QName -> Type -> m (Maybe Type)

+ Agda.TypeChecking.Records: getDefType :: PureTCM m => QName -> Type -> m (Maybe Type)

- Agda.TypeChecking.Records: insertMissingFields :: forall a. QName -> (Name -> a) -> [FieldAssignment' a] -> [Arg Name] -> TCM [NamedArg a]

+ Agda.TypeChecking.Records: insertMissingFields :: forall a. HasRange a => QName -> (Name -> a) -> [FieldAssignment' a] -> [Arg Name] -> Writer [RecordFieldWarning] [NamedArg a]

- Agda.TypeChecking.Records: isEtaVar :: Term -> Type -> TCM (Maybe Int)

+ Agda.TypeChecking.Records: isEtaVar :: forall m. PureTCM m => Term -> Type -> m (Maybe Int)

- Agda.TypeChecking.Records: isRecordType :: (MonadReduce m, HasConstInfo m, HasBuiltins m) => Type -> m (Maybe (QName, Args, Defn))

+ Agda.TypeChecking.Records: isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, Defn))

- Agda.TypeChecking.Records: isSingletonRecord :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m) => QName -> Args -> m (Either MetaId Bool)

+ Agda.TypeChecking.Records: isSingletonRecord :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool

- Agda.TypeChecking.Records: isSingletonRecord' :: forall m. (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m) => Bool -> QName -> Args -> m (Either MetaId (Maybe Term))

+ Agda.TypeChecking.Records: isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m) => Bool -> QName -> Args -> m (Maybe Term)

- Agda.TypeChecking.Records: isSingletonRecordModuloRelevance :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m) => QName -> Args -> m (Either MetaId Bool)

+ Agda.TypeChecking.Records: isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool

- Agda.TypeChecking.Records: isSingletonType :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m) => Type -> m (Either MetaId (Maybe Term))

+ Agda.TypeChecking.Records: isSingletonType :: (PureTCM m, MonadBlock m) => Type -> m (Maybe Term)

- Agda.TypeChecking.Records: isSingletonType' :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m) => Bool -> Type -> m (Either MetaId (Maybe Term))

+ Agda.TypeChecking.Records: isSingletonType' :: (PureTCM m, MonadBlock m) => Bool -> Type -> m (Maybe Term)

- Agda.TypeChecking.Records: isSingletonTypeModuloRelevance :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m) => Type -> m (Either MetaId Bool)

+ Agda.TypeChecking.Records: isSingletonTypeModuloRelevance :: (PureTCM m, MonadBlock m) => Type -> m Bool

- Agda.TypeChecking.Records: orderFields :: forall a. QName -> (Arg Name -> a) -> [Arg Name] -> [(Name, a)] -> TCM [a]

+ Agda.TypeChecking.Records: orderFields :: forall a. HasRange a => QName -> (Arg Name -> a) -> [Arg Name] -> [(Name, a)] -> Writer [RecordFieldWarning] [a]

- Agda.TypeChecking.Records: projectTyped :: (HasConstInfo m, MonadReduce m, MonadDebug m) => Term -> Type -> ProjOrigin -> QName -> m (Maybe (Dom Type, Term, Type))

+ Agda.TypeChecking.Records: projectTyped :: PureTCM m => Term -> Type -> ProjOrigin -> QName -> m (Maybe (Dom Type, Term, Type))

- Agda.TypeChecking.Records: tryRecordType :: (MonadReduce m, HasConstInfo m, HasBuiltins m) => Type -> m (Either (Blocked Type) (QName, Args, Defn))

+ Agda.TypeChecking.Records: tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, Defn))

- Agda.TypeChecking.Records: unguardedRecord :: QName -> TCM ()

+ Agda.TypeChecking.Records: unguardedRecord :: QName -> PatternOrCopattern -> TCM ()

- Agda.TypeChecking.Reduce: ifBlocked :: (Reduce t, IsMeta t, MonadReduce m, HasBuiltins m) => t -> (MetaId -> t -> m a) -> (NotBlocked -> t -> m a) -> m a

+ Agda.TypeChecking.Reduce: ifBlocked :: (Reduce t, IsMeta t, MonadReduce m) => t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a

- Agda.TypeChecking.Reduce: isBlocked :: (Reduce t, IsMeta t, MonadReduce m, HasBuiltins m) => t -> m (Maybe MetaId)

+ Agda.TypeChecking.Reduce: isBlocked :: (Reduce t, IsMeta t, MonadReduce m) => t -> m (Maybe Blocker)

- Agda.TypeChecking.Reduce: isMeta :: (IsMeta a, HasBuiltins m) => a -> m (Maybe MetaId)

+ Agda.TypeChecking.Reduce: isMeta :: IsMeta a => a -> Maybe MetaId

- Agda.TypeChecking.Reduce: reduceDefCopy :: forall m. (MonadReduce m, HasConstInfo m, HasOptions m, ReadTCState m, MonadTCEnv m, MonadDebug m) => QName -> Elims -> m (Reduced () Term)

+ Agda.TypeChecking.Reduce: reduceDefCopy :: forall m. PureTCM m => QName -> Elims -> m (Reduced () Term)

- Agda.TypeChecking.Reduce: reduceHead :: (HasBuiltins m, HasConstInfo m, MonadReduce m, MonadDebug m) => Term -> m (Blocked Term)

+ Agda.TypeChecking.Reduce: reduceHead :: PureTCM m => Term -> m (Blocked Term)

- Agda.TypeChecking.Reduce: unfoldInlined :: (HasConstInfo m, MonadReduce m) => Term -> m Term

+ Agda.TypeChecking.Reduce: unfoldInlined :: PureTCM m => Term -> m Term

- Agda.TypeChecking.Rewriting: rewrite :: Blocked_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)

+ Agda.TypeChecking.Rewriting: rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)

- Agda.TypeChecking.Rewriting: rewriteWith :: Type -> Term -> RewriteRule -> Elims -> ReduceM (Either (Blocked Term) Term)

+ Agda.TypeChecking.Rewriting: rewriteWith :: Type -> (Elims -> Term) -> RewriteRule -> Elims -> ReduceM (Either (Blocked Term) Term)

- Agda.TypeChecking.Rewriting.Clause: clauseQName :: QName -> Int -> TCM QName

+ Agda.TypeChecking.Rewriting.Clause: clauseQName :: (HasConstInfo m, MonadFresh NameId m) => QName -> Int -> m QName

- Agda.TypeChecking.Rewriting.Clause: getClausesAsRewriteRules :: QName -> TCM [RewriteRule]

+ Agda.TypeChecking.Rewriting.Clause: getClausesAsRewriteRules :: (HasConstInfo m, MonadFresh NameId m) => QName -> m [RewriteRule]

- Agda.TypeChecking.Rewriting.Confluence: checkConfluenceOfRules :: [RewriteRule] -> TCM ()

+ Agda.TypeChecking.Rewriting.Confluence: checkConfluenceOfRules :: ConfluenceCheck -> [RewriteRule] -> TCM ()

- Agda.TypeChecking.Rewriting.NonLinMatch: checkPostponedEquations :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, MonadDebug m) => Substitution -> PostponedEquations -> m (Maybe Blocked_)

+ Agda.TypeChecking.Rewriting.NonLinMatch: checkPostponedEquations :: PureTCM m => Substitution -> PostponedEquations -> m (Maybe Blocked_)

- Agda.TypeChecking.Rewriting.NonLinMatch: equal :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m) => Type -> Term -> Term -> m (Maybe Blocked_)

+ Agda.TypeChecking.Rewriting.NonLinMatch: equal :: PureTCM m => Type -> Term -> Term -> m (Maybe Blocked_)

- Agda.TypeChecking.Rewriting.NonLinMatch: nonLinMatch :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, MonadDebug m, Match t a b) => Telescope -> t -> a -> b -> m (Either Blocked_ Substitution)

+ Agda.TypeChecking.Rewriting.NonLinMatch: nonLinMatch :: (PureTCM m, Match t a b) => Telescope -> t -> a -> b -> m (Either Blocked_ Substitution)

- Agda.TypeChecking.Rewriting.NonLinPattern: nlPatToTerm :: (NLPatToTerm p a, NLPatToTerm p' a', Traversable f, p ~ f p', a ~ f a', MonadReduce m, HasBuiltins m, HasConstInfo m, MonadDebug m) => p -> m a

+ Agda.TypeChecking.Rewriting.NonLinPattern: nlPatToTerm :: (NLPatToTerm p a, NLPatToTerm p' a', Traversable f, p ~ f p', a ~ f a', PureTCM m) => p -> m a

- Agda.TypeChecking.Rules.Application: checkArguments :: ExpandHidden -> Range -> [NamedArg Expr] -> Type -> Type -> (MaybeRanges -> Elims -> Type -> CheckedTarget -> TCM Term) -> TCM Term

+ Agda.TypeChecking.Rules.Application: checkArguments :: Comparison -> ExpandHidden -> Range -> [NamedArg Expr] -> Type -> Type -> (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term

- Agda.TypeChecking.Rules.Application: checkArguments_ :: ExpandHidden -> Range -> [NamedArg Expr] -> Telescope -> TCM (Elims, Telescope)

+ Agda.TypeChecking.Rules.Application: checkArguments_ :: Comparison -> ExpandHidden -> Range -> [NamedArg Expr] -> Telescope -> TCM (Elims, Telescope)

- Agda.TypeChecking.Rules.Application: checkProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> NonEmpty QName -> Args -> Type -> Int -> Term -> Type -> TCM Term

+ Agda.TypeChecking.Rules.Application: checkProjAppToKnownPrincipalArg :: Comparison -> Expr -> ProjOrigin -> List1 QName -> Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term

- Agda.TypeChecking.Rules.Data: ClosedType :: QName -> CType

+ Agda.TypeChecking.Rules.Data: ClosedType :: Sort -> QName -> CType

- Agda.TypeChecking.Rules.Decl: checkAxiom :: Axiom -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> TCM ()

+ Agda.TypeChecking.Rules.Decl: checkAxiom :: KindOfName -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> TCM ()

- Agda.TypeChecking.Rules.Decl: checkAxiom' :: Maybe GeneralizeTelescope -> Axiom -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> TCM ()

+ Agda.TypeChecking.Rules.Decl: checkAxiom' :: Maybe GeneralizeTelescope -> KindOfName -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> TCM ()

- Agda.TypeChecking.Rules.Decl: checkPrimitive :: DefInfo -> QName -> Expr -> TCM ()

+ Agda.TypeChecking.Rules.Decl: checkPrimitive :: DefInfo -> QName -> Arg Expr -> TCM ()

- Agda.TypeChecking.Rules.Decl: checkSection :: ModuleInfo -> ModuleName -> GeneralizeTelescope -> [Declaration] -> TCM ()

+ Agda.TypeChecking.Rules.Decl: checkSection :: ModuleName -> GeneralizeTelescope -> [Declaration] -> TCM ()

- Agda.TypeChecking.Rules.Def: WithFunction :: QName -> QName -> Type -> Telescope -> Telescope -> Telescope -> [WithHiding (Term, EqualityView)] -> Type -> [NamedArg DeBruijnPattern] -> Nat -> Permutation -> Permutation -> Permutation -> [Clause] -> WithFunctionProblem

+ Agda.TypeChecking.Rules.Def: WithFunction :: QName -> QName -> Type -> Telescope -> Telescope -> Telescope -> [Arg (Term, EqualityView)] -> Type -> [NamedArg DeBruijnPattern] -> Nat -> Permutation -> Permutation -> Permutation -> [Clause] -> Substitution -> WithFunctionProblem

- Agda.TypeChecking.Rules.Def: [wfExprs] :: WithFunctionProblem -> [WithHiding (Term, EqualityView)]

+ Agda.TypeChecking.Rules.Def: [wfExprs] :: WithFunctionProblem -> [Arg (Term, EqualityView)]

- Agda.TypeChecking.Rules.Def: checkWithFunction :: [Name] -> WithFunctionProblem -> TCM ()

+ Agda.TypeChecking.Rules.Def: checkWithFunction :: [Name] -> WithFunctionProblem -> TCM (Maybe Term)

- Agda.TypeChecking.Rules.Def: checkWithRHS :: QName -> QName -> Type -> LHSResult -> [WithHiding (Term, EqualityView)] -> [Clause] -> TCM (Maybe Term, WithFunctionProblem)

+ Agda.TypeChecking.Rules.Def: checkWithRHS :: QName -> QName -> Type -> LHSResult -> [Arg (Term, EqualityView)] -> [Clause] -> TCM (Maybe Term, WithFunctionProblem)

- Agda.TypeChecking.Rules.Def: insertPatterns :: [Pattern] -> RHS -> RHS

+ Agda.TypeChecking.Rules.Def: insertPatterns :: [Arg Pattern] -> RHS -> RHS

- Agda.TypeChecking.Rules.Def: insertPatternsLHSCore :: [Pattern] -> LHSCore -> LHSCore

+ Agda.TypeChecking.Rules.Def: insertPatternsLHSCore :: [Arg Pattern] -> LHSCore -> LHSCore

- Agda.TypeChecking.Rules.LHS: checkSortOfSplitVar :: (MonadTCM m, MonadReduce m, MonadError TCErr m, ReadTCState m, MonadDebug m, LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty) => DataOrRecord -> a -> Maybe ty -> m ()

+ Agda.TypeChecking.Rules.LHS: checkSortOfSplitVar :: (MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty) => DataOrRecord -> a -> Telescope -> Maybe ty -> m ()

- Agda.TypeChecking.Rules.LHS: isFlexiblePattern :: IsFlexiblePattern a => a -> TCM Bool

+ Agda.TypeChecking.Rules.LHS: isFlexiblePattern :: (IsFlexiblePattern a, HasConstInfo m, MonadDebug m) => a -> m Bool

- Agda.TypeChecking.Rules.LHS: maybeFlexiblePattern :: IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind

+ Agda.TypeChecking.Rules.LHS: maybeFlexiblePattern :: (IsFlexiblePattern a, HasConstInfo m, MonadDebug m) => a -> MaybeT m FlexibleVarKind

- Agda.TypeChecking.Rules.LHS.Implicit: insertImplicitPatterns :: ExpandHidden -> [NamedArg Pattern] -> Telescope -> TCM [NamedArg Pattern]

+ Agda.TypeChecking.Rules.LHS.Implicit: insertImplicitPatterns :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m) => ExpandHidden -> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]

- Agda.TypeChecking.Rules.LHS.Implicit: insertImplicitPatternsT :: ExpandHidden -> [NamedArg Pattern] -> Type -> TCM [NamedArg Pattern]

+ Agda.TypeChecking.Rules.LHS.Implicit: insertImplicitPatternsT :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m) => ExpandHidden -> [NamedArg Pattern] -> Type -> m [NamedArg Pattern]

- Agda.TypeChecking.Rules.LHS.Implicit: insertImplicitSizeLtPatterns :: Type -> TCM [NamedArg Pattern]

+ Agda.TypeChecking.Rules.LHS.Implicit: insertImplicitSizeLtPatterns :: PureTCM m => Type -> m [NamedArg Pattern]

- Agda.TypeChecking.Rules.LHS.Problem: AsB :: Name -> Term -> Type -> AsBinding

+ Agda.TypeChecking.Rules.LHS.Problem: AsB :: Name -> Term -> Type -> Modality -> AsBinding

- Agda.TypeChecking.Rules.LHS.Problem: LeftoverPatterns :: IntMap [(Name, PatVarPosition)] -> [AsBinding] -> [DotPattern] -> [AbsurdPattern] -> [Pattern] -> LeftoverPatterns

+ Agda.TypeChecking.Rules.LHS.Problem: LeftoverPatterns :: IntMap [(Name, PatVarPosition)] -> [AsBinding] -> [DotPattern] -> [AbsurdPattern] -> [AnnotationPattern] -> [Pattern] -> LeftoverPatterns

- Agda.TypeChecking.Rules.LHS.Problem: getLeftoverPatterns :: [ProblemEq] -> TCM LeftoverPatterns

+ Agda.TypeChecking.Rules.LHS.Problem: getLeftoverPatterns :: forall m. PureTCM m => [ProblemEq] -> m LeftoverPatterns

- Agda.TypeChecking.Rules.LHS.ProblemRest: updateProblemRest :: LHSState a -> TCM (LHSState a)

+ Agda.TypeChecking.Rules.LHS.ProblemRest: updateProblemRest :: forall m a. (PureTCM m, MonadError TCErr m, MonadTrace m, MonadFresh NameId m) => LHSState a -> m (LHSState a)

- Agda.TypeChecking.Rules.LHS.ProblemRest: useNamesFromProblemEqs :: [ProblemEq] -> Telescope -> TCM Telescope

+ Agda.TypeChecking.Rules.LHS.ProblemRest: useNamesFromProblemEqs :: forall m. PureTCM m => [ProblemEq] -> Telescope -> m Telescope

- Agda.TypeChecking.Rules.LHS.Unify: unifyIndices :: MonadTCM tcm => Telescope -> FlexibleVars -> Type -> Args -> Args -> tcm UnificationResult

+ Agda.TypeChecking.Rules.LHS.Unify: unifyIndices :: (PureTCM m, MonadBench m, BenchPhase m ~ Phase) => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnificationResult

- Agda.TypeChecking.Rules.Record: checkRecDef :: DefInfo -> QName -> UniverseCheck -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe QName -> DataDefParams -> Expr -> [Field] -> TCM ()

+ Agda.TypeChecking.Rules.Record: checkRecDef :: DefInfo -> QName -> UniverseCheck -> RecordDirectives -> DataDefParams -> Expr -> [Field] -> TCM ()

- Agda.TypeChecking.Rules.Term: addTypedPatterns :: [NamedArg Binder] -> TCM a -> TCM a

+ Agda.TypeChecking.Rules.Term: addTypedPatterns :: List1 (NamedArg Binder) -> TCM a -> TCM a

- Agda.TypeChecking.Rules.Term: catchIlltypedPatternBlockedOnMeta :: TCM a -> ((TCErr, MetaId) -> TCM a) -> TCM a

+ Agda.TypeChecking.Rules.Term: catchIlltypedPatternBlockedOnMeta :: TCM a -> ((TCErr, Blocker) -> TCM a) -> TCM a

- Agda.TypeChecking.Rules.Term: checkExtendedLambda :: Comparison -> ExprInfo -> DefInfo -> QName -> [Clause] -> Expr -> Type -> TCM Term

+ Agda.TypeChecking.Rules.Term: checkExtendedLambda :: Comparison -> ExprInfo -> DefInfo -> Erased -> QName -> List1 Clause -> Expr -> Type -> TCM Term

- Agda.TypeChecking.Rules.Term: checkLetBindings :: [LetBinding] -> TCM a -> TCM a

+ Agda.TypeChecking.Rules.Term: checkLetBindings :: Foldable t => t LetBinding -> TCM a -> TCM a

- Agda.TypeChecking.Rules.Term: checkPostponedLambda :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> Expr -> Type -> TCM Term

+ Agda.TypeChecking.Rules.Term: checkPostponedLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> Expr -> Type -> TCM Term

- Agda.TypeChecking.Rules.Term: inferExprForWith :: Expr -> TCM (Term, Type)

+ Agda.TypeChecking.Rules.Term: inferExprForWith :: Arg Expr -> TCM (Term, Type)

- Agda.TypeChecking.Rules.Term: insertHiddenLambdas :: Hiding -> Type -> (MetaId -> Type -> TCM Term) -> (Type -> TCM Term) -> TCM Term

+ Agda.TypeChecking.Rules.Term: insertHiddenLambdas :: Hiding -> Type -> (Blocker -> Type -> TCM Term) -> (Type -> TCM Term) -> TCM Term

- Agda.TypeChecking.Rules.Term: lambdaModalityCheck :: LensModality dom => dom -> ArgInfo -> TCM ArgInfo

+ Agda.TypeChecking.Rules.Term: lambdaModalityCheck :: (LensAnnotation dom, LensModality dom) => dom -> ArgInfo -> TCM ArgInfo

- Agda.TypeChecking.Serialise.Base: Dict :: !HashTable Node Int32 -> !HashTable String Int32 -> !HashTable Text Int32 -> !HashTable Integer Int32 -> !HashTable Double Int32 -> !HashTable (Ptr Term) Int32 -> !HashTable NameId Int32 -> !HashTable QNameId Int32 -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !HashTable String Int -> Bool -> !HashTable AbsolutePath Int32 -> Dict

+ Agda.TypeChecking.Serialise.Base: Dict :: !HashTable Node Int32 -> !HashTable String Int32 -> !HashTable Text Int32 -> !HashTable Text Int32 -> !HashTable Integer Int32 -> !HashTable Double Int32 -> !HashTable (Ptr Term) Int32 -> !HashTable NameId Int32 -> !HashTable QNameId Int32 -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !HashTable String Int -> Bool -> !HashTable AbsolutePath Int32 -> Dict

- Agda.TypeChecking.Serialise.Base: St :: !Array Int32 Node -> !Array Int32 String -> !Array Int32 Text -> !Array Int32 Integer -> !Array Int32 Double -> !Memo -> !ModuleToSource -> [AbsolutePath] -> St

+ Agda.TypeChecking.Serialise.Base: St :: !Array Int32 Node -> !Array Int32 String -> !Array Int32 Text -> !Array Int32 Text -> !Array Int32 Integer -> !Array Int32 Double -> !Memo -> !ModuleToSource -> [AbsolutePath] -> St

- Agda.TypeChecking.SizedTypes: deepSizeView :: Term -> TCM DeepSizeView

+ Agda.TypeChecking.SizedTypes: deepSizeView :: (PureTCM m, MonadTCError m) => Term -> m DeepSizeView

- Agda.TypeChecking.SizedTypes: getSizeConstraints :: (Comparison -> Bool) -> TCM [Closure Constraint]

+ Agda.TypeChecking.SizedTypes: getSizeConstraints :: (Comparison -> Bool) -> TCM [ProblemConstraint]

- Agda.TypeChecking.SizedTypes: isBounded :: (MonadReduce m, MonadTCEnv m, HasBuiltins m) => Nat -> m BoundedSize

+ Agda.TypeChecking.SizedTypes: isBounded :: PureTCM m => Nat -> m BoundedSize

- Agda.TypeChecking.SizedTypes: oldComputeSizeConstraints :: [Closure Constraint] -> TCM [OldSizeConstraint]

+ Agda.TypeChecking.SizedTypes: oldComputeSizeConstraints :: [ProblemConstraint] -> TCM [OldSizeConstraint]

- Agda.TypeChecking.SizedTypes: oldSizeExpr :: (MonadReduce m, MonadDebug m, MonadError TCErr m, HasBuiltins m) => Term -> m (OldSizeExpr, Int)

+ Agda.TypeChecking.SizedTypes: oldSizeExpr :: (PureTCM m, MonadBlock m) => Term -> m (OldSizeExpr, Int)

- Agda.TypeChecking.SizedTypes: sizeMaxView :: (MonadReduce m, HasBuiltins m) => Term -> m SizeMaxView

+ Agda.TypeChecking.SizedTypes: sizeMaxView :: PureTCM m => Term -> m SizeMaxView

- Agda.TypeChecking.SizedTypes: takeSizeConstraints :: (Comparison -> Bool) -> TCM [Closure Constraint]

+ Agda.TypeChecking.SizedTypes: takeSizeConstraints :: (Comparison -> Bool) -> TCM [ProblemConstraint]

- Agda.TypeChecking.SizedTypes.Solve: castConstraintToCurrentContext :: Closure Constraint -> MaybeT TCM Constraint

+ Agda.TypeChecking.SizedTypes.Solve: castConstraintToCurrentContext :: ProblemConstraint -> MaybeT TCM ProblemConstraint

- Agda.TypeChecking.SizedTypes.Solve: computeSizeConstraint :: Closure Constraint -> TCM (Maybe HypSizeConstraint)

+ Agda.TypeChecking.SizedTypes.Solve: computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint)

- Agda.TypeChecking.SizedTypes.Solve: solveCluster :: DefaultToInfty -> NonEmpty (CC, HypSizeConstraint) -> TCM ()

+ Agda.TypeChecking.SizedTypes.Solve: solveCluster :: DefaultToInfty -> List1 (CC, HypSizeConstraint) -> TCM ()

- Agda.TypeChecking.SizedTypes.Solve: type CC = Closure Constraint

+ Agda.TypeChecking.SizedTypes.Solve: type CC = ProblemConstraint

- Agda.TypeChecking.SizedTypes.Syntax: class Flexs flex a | a -> flex

+ Agda.TypeChecking.SizedTypes.Syntax: class Ord (FlexOf a) => Flexs a where {

- Agda.TypeChecking.SizedTypes.Syntax: class Rigids r a

+ Agda.TypeChecking.SizedTypes.Syntax: class Ord (RigidOf a) => Rigids a where {

- Agda.TypeChecking.SizedTypes.Syntax: flexs :: Flexs flex a => a -> Set flex

+ Agda.TypeChecking.SizedTypes.Syntax: flexs :: Flexs a => a -> Set (FlexOf a)

- Agda.TypeChecking.SizedTypes.Syntax: rigids :: Rigids r a => a -> Set r

+ Agda.TypeChecking.SizedTypes.Syntax: rigids :: Rigids a => a -> Set (RigidOf a)

- Agda.TypeChecking.Sort: ifIsSort :: MonadReduce m => Type -> (Sort -> m a) -> m a -> m a

+ Agda.TypeChecking.Sort: ifIsSort :: (MonadReduce m, MonadBlock m) => Type -> (Sort -> m a) -> m a -> m a

- Agda.TypeChecking.Sort: inferPiSort :: (MonadReduce m, MonadAddContext m, MonadDebug m) => Dom Type -> Abs Sort -> m Sort

+ Agda.TypeChecking.Sort: inferPiSort :: PureTCM m => Dom Type -> Abs Sort -> m Sort

- Agda.TypeChecking.Sort: inferUnivSort :: (MonadReduce m, MonadConstraint m, HasOptions m) => Sort -> m Sort

+ Agda.TypeChecking.Sort: inferUnivSort :: (PureTCM m, MonadConstraint m) => Sort -> m Sort

- Agda.TypeChecking.Sort: shouldBeSort :: (MonadReduce m, MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Type -> m Sort

+ Agda.TypeChecking.Sort: shouldBeSort :: (PureTCM m, MonadBlock m, MonadError TCErr m) => Type -> m Sort

- Agda.TypeChecking.Sort: sortOf :: forall m. (MonadReduce m, MonadTCEnv m, MonadAddContext m, HasBuiltins m, HasConstInfo m) => Term -> m Sort

+ Agda.TypeChecking.Sort: sortOf :: forall m. (PureTCM m, MonadBlock m) => Term -> m Sort

- Agda.TypeChecking.Substitute: EmptyS :: Empty -> Substitution' a

+ Agda.TypeChecking.Substitute: EmptyS :: Impossible -> Substitution' a

- Agda.TypeChecking.Substitute: Strengthen :: Empty -> Substitution' a -> Substitution' a

+ Agda.TypeChecking.Substitute: Strengthen :: Impossible -> Substitution' a -> Substitution' a

- Agda.TypeChecking.Substitute: applyNLPatSubst :: Subst Term a => Substitution' NLPat -> a -> a

+ Agda.TypeChecking.Substitute: applyNLPatSubst :: TermSubst a => Substitution' NLPat -> a -> a

- Agda.TypeChecking.Substitute: applyNLSubstToDom :: Subst NLPat a => Substitution' NLPat -> Dom a -> Dom a

+ Agda.TypeChecking.Substitute: applyNLSubstToDom :: SubstWith NLPat a => Substitution' NLPat -> Dom a -> Dom a

- Agda.TypeChecking.Substitute: applyPatSubst :: Subst Term a => PatternSubstitution -> a -> a

+ Agda.TypeChecking.Substitute: applyPatSubst :: TermSubst a => PatternSubstitution -> a -> a

- Agda.TypeChecking.Substitute: applySubstTerm :: forall t. (Coercible t Term, Subst t t, Apply t) => Substitution' t -> t -> t

+ Agda.TypeChecking.Substitute: applySubstTerm :: forall t. (Coercible t Term, EndoSubst t, Apply t) => Substitution' t -> t -> t

- Agda.TypeChecking.Substitute: applyTermE :: forall t. (Coercible Term t, Apply t, Subst t t) => (Empty -> Term -> Elims -> Term) -> t -> Elims -> t

+ Agda.TypeChecking.Substitute: applyTermE :: forall t. (Coercible Term t, Apply t, EndoSubst t) => (Empty -> Term -> Elims -> Term) -> t -> Elims -> t

- Agda.TypeChecking.Substitute: piSort :: Dom Type -> Abs Sort -> Sort

+ Agda.TypeChecking.Substitute: piSort :: Dom Term -> Sort -> Abs Sort -> Sort

- Agda.TypeChecking.Substitute: piSort' :: Dom Type -> Abs Sort -> Maybe Sort

+ Agda.TypeChecking.Substitute: piSort' :: Dom Term -> Sort -> Abs Sort -> Maybe Sort

- Agda.TypeChecking.Substitute: renameP :: Subst t a => Empty -> Permutation -> a -> a

+ Agda.TypeChecking.Substitute: renameP :: Subst a => Impossible -> Permutation -> a -> a

- Agda.TypeChecking.Substitute: renaming :: forall a. DeBruijn a => Empty -> Permutation -> Substitution' a

+ Agda.TypeChecking.Substitute: renaming :: forall a. DeBruijn a => Impossible -> Permutation -> Substitution' a

- Agda.TypeChecking.Substitute: univSort :: Maybe Sort -> Sort -> Sort

+ Agda.TypeChecking.Substitute: univSort :: Sort -> Sort

- Agda.TypeChecking.Substitute: univSort' :: Maybe Sort -> Sort -> Maybe Sort

+ Agda.TypeChecking.Substitute: univSort' :: Sort -> Maybe Sort

- Agda.TypeChecking.Substitute.Class: absApp :: Subst t a => Abs a -> t -> a

+ Agda.TypeChecking.Substitute.Class: absApp :: Subst a => Abs a -> SubstArg a -> a

- Agda.TypeChecking.Substitute.Class: absBody :: Subst t a => Abs a -> a

+ Agda.TypeChecking.Substitute.Class: absBody :: Subst a => Abs a -> a

- Agda.TypeChecking.Substitute.Class: applySubst :: (Subst t a, a ~ f b, Functor f, Subst t b) => Substitution' t -> a -> a

+ Agda.TypeChecking.Substitute.Class: applySubst :: (Subst a, a ~ f b, Functor f, Subst b, SubstArg a ~ SubstArg b) => Substitution' (SubstArg a) -> a -> a

- Agda.TypeChecking.Substitute.Class: class DeBruijn t => Subst t a | a -> t

+ Agda.TypeChecking.Substitute.Class: class DeBruijn (SubstArg a) => Subst a where {

- Agda.TypeChecking.Substitute.Class: compactS :: DeBruijn a => Empty -> [Maybe a] -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: compactS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a

- Agda.TypeChecking.Substitute.Class: composeS :: Subst a a => Substitution' a -> Substitution' a -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: composeS :: EndoSubst a => Substitution' a -> Substitution' a -> Substitution' a

- Agda.TypeChecking.Substitute.Class: inplaceS :: Subst a a => Int -> a -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: inplaceS :: EndoSubst a => Int -> a -> Substitution' a

- Agda.TypeChecking.Substitute.Class: lazyAbsApp :: Subst t a => Abs a -> t -> a

+ Agda.TypeChecking.Substitute.Class: lazyAbsApp :: Subst a => Abs a -> SubstArg a -> a

- Agda.TypeChecking.Substitute.Class: listS :: Subst a a => [(Int, a)] -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: listS :: EndoSubst a => [(Int, a)] -> Substitution' a

- Agda.TypeChecking.Substitute.Class: lookupS :: Subst a a => Substitution' a -> Nat -> a

+ Agda.TypeChecking.Substitute.Class: lookupS :: EndoSubst a => Substitution' a -> Nat -> a

- Agda.TypeChecking.Substitute.Class: mkAbs :: (Subst t a, Free a) => ArgName -> a -> Abs a

+ Agda.TypeChecking.Substitute.Class: mkAbs :: (Subst a, Free a) => ArgName -> a -> Abs a

- Agda.TypeChecking.Substitute.Class: noabsApp :: Subst t a => Empty -> Abs a -> a

+ Agda.TypeChecking.Substitute.Class: noabsApp :: Subst a => Impossible -> Abs a -> a

- Agda.TypeChecking.Substitute.Class: prependS :: DeBruijn a => Empty -> [Maybe a] -> Substitution' a -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: prependS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a -> Substitution' a

- Agda.TypeChecking.Substitute.Class: raise :: Subst t a => Nat -> a -> a

+ Agda.TypeChecking.Substitute.Class: raise :: Subst a => Nat -> a -> a

- Agda.TypeChecking.Substitute.Class: raiseFrom :: Subst t a => Nat -> Nat -> a -> a

+ Agda.TypeChecking.Substitute.Class: raiseFrom :: Subst a => Nat -> Nat -> a -> a

- Agda.TypeChecking.Substitute.Class: reAbs :: (Subst t a, Free a) => Abs a -> Abs a

+ Agda.TypeChecking.Substitute.Class: reAbs :: (Subst a, Free a) => Abs a -> Abs a

- Agda.TypeChecking.Substitute.Class: strengthen :: Subst t a => Empty -> a -> a

+ Agda.TypeChecking.Substitute.Class: strengthen :: Subst a => Impossible -> a -> a

- Agda.TypeChecking.Substitute.Class: strengthenS :: Empty -> Int -> Substitution' a

+ Agda.TypeChecking.Substitute.Class: strengthenS :: Impossible -> Int -> Substitution' a

- Agda.TypeChecking.Substitute.Class: subst :: Subst t a => Int -> t -> a -> a

+ Agda.TypeChecking.Substitute.Class: subst :: Subst a => Int -> SubstArg a -> a -> a

- Agda.TypeChecking.Substitute.Class: substUnder :: Subst t a => Nat -> t -> a -> a

+ Agda.TypeChecking.Substitute.Class: substUnder :: Subst a => Nat -> SubstArg a -> a -> a

- Agda.TypeChecking.Substitute.Class: underAbs :: Subst t a => (a -> b -> b) -> a -> Abs b -> Abs b

+ Agda.TypeChecking.Substitute.Class: underAbs :: Subst a => (a -> b -> b) -> a -> Abs b -> Abs b

- Agda.TypeChecking.Substitute.Class: underLambdas :: Subst Term a => Int -> (a -> Term -> Term) -> a -> Term -> Term

+ Agda.TypeChecking.Substitute.Class: underLambdas :: TermSubst a => Int -> (a -> Term -> Term) -> a -> Term -> Term

- Agda.TypeChecking.Telescope: OutputTypeNameNotYetKnown :: OutputTypeName

+ Agda.TypeChecking.Telescope: OutputTypeNameNotYetKnown :: Blocker -> OutputTypeName

- Agda.TypeChecking.Telescope: flattenTel :: Subst Term a => Tele (Dom a) -> [Dom a]

+ Agda.TypeChecking.Telescope: flattenTel :: TermSubst a => Tele (Dom a) -> [Dom a]

- Agda.TypeChecking.Telescope: ifNotPiOrPathType :: (MonadReduce tcm, MonadTCM tcm) => Type -> (Type -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a

+ Agda.TypeChecking.Telescope: ifNotPiOrPathType :: (MonadReduce tcm, HasBuiltins tcm) => Type -> (Type -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a

- Agda.TypeChecking.Telescope: isPath :: (MonadReduce m, HasBuiltins m) => Type -> m (Maybe (Dom Type, Abs Type))

+ Agda.TypeChecking.Telescope: isPath :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type))

- Agda.TypeChecking.Telescope: pathViewAsPi :: (MonadReduce m, HasBuiltins m) => Type -> m (Either (Dom Type, Abs Type) Type)

+ Agda.TypeChecking.Telescope: pathViewAsPi :: PureTCM m => Type -> m (Either (Dom Type, Abs Type) Type)

- Agda.TypeChecking.Telescope: pathViewAsPi' :: (MonadReduce m, HasBuiltins m) => Type -> m (Either ((Dom Type, Abs Type), (Term, Term)) Type)

+ Agda.TypeChecking.Telescope: pathViewAsPi' :: PureTCM m => Type -> m (Either ((Dom Type, Abs Type), (Term, Term)) Type)

- Agda.TypeChecking.Telescope: piApplyM :: (PiApplyM a, MonadReduce m) => Type -> a -> m Type

+ Agda.TypeChecking.Telescope: piApplyM :: (PiApplyM a, MonadReduce m, HasBuiltins m) => Type -> a -> m Type

- Agda.TypeChecking.Telescope: piOrPath :: Type -> TCM (Either (Dom Type, Abs Type) Type)

+ Agda.TypeChecking.Telescope: piOrPath :: HasBuiltins m => Type -> m (Either (Dom Type, Abs Type) Type)

- Agda.TypeChecking.Telescope: telViewPath :: Type -> TCM TelView

+ Agda.TypeChecking.Telescope: telViewPath :: PureTCM m => Type -> m TelView

- Agda.TypeChecking.Telescope: telViewPathBoundaryP :: (MonadReduce m, HasBuiltins m) => Type -> m (TelView, Boundary)

+ Agda.TypeChecking.Telescope: telViewPathBoundaryP :: PureTCM m => Type -> m (TelView, Boundary)

- Agda.TypeChecking.Telescope: telViewUpToPath :: Int -> Type -> TCM TelView

+ Agda.TypeChecking.Telescope: telViewUpToPath :: PureTCM m => Int -> Type -> m TelView

- Agda.TypeChecking.Telescope: telViewUpToPathBoundary :: (MonadReduce m, HasBuiltins m) => Int -> Type -> m (TelView, Boundary)

+ Agda.TypeChecking.Telescope: telViewUpToPathBoundary :: PureTCM m => Int -> Type -> m (TelView, Boundary)

- Agda.TypeChecking.Telescope: telViewUpToPathBoundary' :: (MonadReduce m, HasBuiltins m) => Int -> Type -> m (TelView, Boundary)

+ Agda.TypeChecking.Telescope: telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView, Boundary)

- Agda.TypeChecking.Telescope: telViewUpToPathBoundaryP :: (MonadReduce m, HasBuiltins m) => Int -> Type -> m (TelView, Boundary)

+ Agda.TypeChecking.Telescope: telViewUpToPathBoundaryP :: PureTCM m => Int -> Type -> m (TelView, Boundary)

- Agda.TypeChecking.Telescope.Path: telePiPath :: (Abs Type -> Abs Type) -> Telescope -> Type -> Boundary -> TCM Type

+ Agda.TypeChecking.Telescope.Path: telePiPath :: (Abs Type -> Abs Type) -> ([Arg ArgName] -> Term -> Term) -> Telescope -> Type -> Boundary -> TCM Type

- Agda.TypeChecking.Unquote: unquoteNString :: Arg Term -> UnquoteM String

+ Agda.TypeChecking.Unquote: unquoteNString :: Arg Term -> UnquoteM Text

- Agda.TypeChecking.Warnings: addWarning :: MonadWarning m => TCWarning -> m ()

+ Agda.TypeChecking.Warnings: addWarning :: (MonadWarning m, MonadWarning n, MonadTrans t, t n ~ m) => TCWarning -> m ()

- Agda.TypeChecking.Warnings: warning :: MonadWarning m => Warning -> m ()

+ Agda.TypeChecking.Warnings: warning :: (HasCallStack, MonadWarning m) => Warning -> m ()

- Agda.TypeChecking.Warnings: warning_ :: MonadWarning m => Warning -> m TCWarning

+ Agda.TypeChecking.Warnings: warning_ :: (HasCallStack, MonadWarning m) => Warning -> m TCWarning

- Agda.TypeChecking.Warnings: warnings :: MonadWarning m => [Warning] -> m ()

+ Agda.TypeChecking.Warnings: warnings :: (HasCallStack, MonadWarning m) => [Warning] -> m ()

- Agda.TypeChecking.With: splitTelForWith :: Telescope -> Type -> [WithHiding (Term, EqualityView)] -> (Telescope, Telescope, Permutation, Type, [WithHiding (Term, EqualityView)])

+ Agda.TypeChecking.With: splitTelForWith :: Telescope -> Type -> [Arg (Term, EqualityView)] -> (Telescope, Telescope, Permutation, Type, [Arg (Term, EqualityView)])

- Agda.TypeChecking.With: withArguments :: [WithHiding (Term, EqualityView)] -> [WithHiding Term]

+ Agda.TypeChecking.With: withArguments :: [Arg (Term, EqualityView)] -> TCM [Arg Term]

- Agda.TypeChecking.With: withFunctionType :: Telescope -> [WithHiding (Term, EqualityView)] -> Telescope -> Type -> TCM (Type, Nat)

+ Agda.TypeChecking.With: withFunctionType :: Telescope -> [Arg (Term, EqualityView)] -> Telescope -> Type -> [(Int, (Term, Term))] -> TCM (Type, Nat)

- Agda.Utils.Benchmark: billPureTo :: MonadBench a m => Account a -> c -> m c

+ Agda.Utils.Benchmark: billPureTo :: MonadBench m => Account (BenchPhase m) -> c -> m c

- Agda.Utils.Benchmark: billTo :: MonadBench a m => Account a -> m c -> m c

+ Agda.Utils.Benchmark: billTo :: MonadBench m => Account (BenchPhase m) -> m c -> m c

- Agda.Utils.Benchmark: billToCPS :: MonadBench a m => Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c

+ Agda.Utils.Benchmark: billToCPS :: MonadBench m => Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c

- Agda.Utils.Benchmark: class (Ord a, Functor m, MonadIO m) => MonadBench a m | m -> a

+ Agda.Utils.Benchmark: class (Ord (BenchPhase m), Functor m, MonadIO m) => MonadBench m where {

- Agda.Utils.Benchmark: finally :: MonadBench a m => m b -> m c -> m b

+ Agda.Utils.Benchmark: finally :: MonadBench m => m b -> m c -> m b

- Agda.Utils.Benchmark: getBenchmark :: MonadBench a m => m (Benchmark a)

+ Agda.Utils.Benchmark: getBenchmark :: MonadBench m => m (Benchmark (BenchPhase m))

- Agda.Utils.Benchmark: getsBenchmark :: MonadBench a m => (Benchmark a -> c) -> m c

+ Agda.Utils.Benchmark: getsBenchmark :: MonadBench m => (Benchmark (BenchPhase m) -> c) -> m c

- Agda.Utils.Benchmark: modifyBenchmark :: MonadBench a m => (Benchmark a -> Benchmark a) -> m ()

+ Agda.Utils.Benchmark: modifyBenchmark :: MonadBench m => (Benchmark (BenchPhase m) -> Benchmark (BenchPhase m)) -> m ()

- Agda.Utils.Benchmark: putBenchmark :: MonadBench a m => Benchmark a -> m ()

+ Agda.Utils.Benchmark: putBenchmark :: MonadBench m => Benchmark (BenchPhase m) -> m ()

- Agda.Utils.Benchmark: reset :: MonadBench a m => m ()

+ Agda.Utils.Benchmark: reset :: MonadBench m => m ()

- Agda.Utils.Benchmark: setBenchmarking :: MonadBench a m => BenchmarkOn a -> m ()

+ Agda.Utils.Benchmark: setBenchmarking :: MonadBench m => BenchmarkOn (BenchPhase m) -> m ()

- Agda.Utils.Benchmark: switchBenchmarking :: MonadBench a m => Maybe (Account a) -> m (Maybe (Account a))

+ Agda.Utils.Benchmark: switchBenchmarking :: MonadBench m => Maybe (Account (BenchPhase m)) -> m (Maybe (Account (BenchPhase m)))

- Agda.Utils.BiMap: BiMap :: Map a b -> Map b a -> BiMap a b

+ Agda.Utils.BiMap: BiMap :: Map k v -> Map (Tag v) k -> BiMap k v

- Agda.Utils.BiMap: [biMapBack] :: BiMap a b -> Map b a

+ Agda.Utils.BiMap: [biMapBack] :: BiMap k v -> Map (Tag v) k

- Agda.Utils.BiMap: [biMapThere] :: BiMap a b -> Map a b

+ Agda.Utils.BiMap: [biMapThere] :: BiMap k v -> Map k v

- Agda.Utils.BiMap: data BiMap a b

+ Agda.Utils.BiMap: data BiMap k v

- Agda.Utils.BiMap: fromList :: (Ord a, Ord b) => [(a, b)] -> BiMap a b

+ Agda.Utils.BiMap: fromList :: (Ord k, Ord (Tag v), HasTag v) => [(k, v)] -> BiMap k v

- Agda.Utils.BiMap: insert :: (Ord a, Ord b) => a -> b -> BiMap a b -> BiMap a b

+ Agda.Utils.BiMap: insert :: (Ord k, HasTag v, Ord (Tag v)) => k -> v -> BiMap k v -> BiMap k v

- Agda.Utils.BiMap: invLookup :: Ord b => b -> BiMap a b -> Maybe a

+ Agda.Utils.BiMap: invLookup :: Ord (Tag v) => Tag v -> BiMap k v -> Maybe k

- Agda.Utils.BiMap: lookup :: Ord a => a -> BiMap a b -> Maybe b

+ Agda.Utils.BiMap: lookup :: Ord k => k -> BiMap k v -> Maybe v

- Agda.Utils.BiMap: singleton :: a -> b -> BiMap a b

+ Agda.Utils.BiMap: singleton :: HasTag v => k -> v -> BiMap k v

- Agda.Utils.BiMap: toList :: BiMap a b -> [(a, b)]

+ Agda.Utils.BiMap: toList :: BiMap k v -> [(k, v)]

- Agda.Utils.BiMap: union :: (Ord a, Ord b) => BiMap a b -> BiMap a b -> BiMap a b

+ Agda.Utils.BiMap: union :: (Ord k, Ord (Tag v)) => BiMap k v -> BiMap k v -> BiMap k v

- Agda.Utils.Either: groupByEither :: forall a b. [Either a b] -> [Either [a] [b]]

+ Agda.Utils.Either: groupByEither :: forall a b. [Either a b] -> [Either (List1 a) (List1 b)]

- Agda.Utils.Either: maybeToEither :: Maybe a -> Either () a

+ Agda.Utils.Either: maybeToEither :: e -> Maybe a -> Either e a

- Agda.Utils.Haskell.Syntax: String :: String -> Literal

+ Agda.Utils.Haskell.Syntax: String :: Text -> Literal

- Agda.Utils.Impossible: Impossible :: String -> Integer -> Impossible

+ Agda.Utils.Impossible: Impossible :: CallStack -> Impossible

- Agda.Utils.Impossible: Unreachable :: String -> Integer -> Impossible

+ Agda.Utils.Impossible: Unreachable :: CallStack -> Impossible

- Agda.Utils.Maybe: whenNothing :: Monad m => Maybe a -> m () -> m ()

+ Agda.Utils.Maybe: whenNothing :: Monoid m => Maybe a -> m -> m

- Agda.Utils.Pretty: fsep :: [Doc] -> Doc

+ Agda.Utils.Pretty: fsep :: Foldable t => t Doc -> Doc

- Agda.Utils.Pretty: hcat :: [Doc] -> Doc

+ Agda.Utils.Pretty: hcat :: Foldable t => t Doc -> Doc

- Agda.Utils.Pretty: hsep :: [Doc] -> Doc

+ Agda.Utils.Pretty: hsep :: Foldable t => t Doc -> Doc

- Agda.Utils.Pretty: punctuate :: Doc -> [Doc] -> [Doc]

+ Agda.Utils.Pretty: punctuate :: Foldable t => Doc -> t Doc -> [Doc]

- Agda.Utils.Pretty: sep :: [Doc] -> Doc

+ Agda.Utils.Pretty: sep :: Foldable t => t Doc -> Doc

- Agda.Utils.Pretty: vcat :: [Doc] -> Doc

+ Agda.Utils.Pretty: vcat :: Foldable t => t Doc -> Doc

- Agda.Utils.Size: size :: Sized a => a -> Int

+ Agda.Utils.Size: size :: (Sized a, Foldable t, t b ~ a) => a -> Int

- Agda.Utils.Suffix: suffixView :: String -> (String, Suffix)

+ Agda.Utils.Suffix: suffixView :: String -> (String, Maybe Suffix)

- Agda.Utils.WithDefault: Value :: Bool -> WithDefault (b :: Bool)

+ Agda.Utils.WithDefault: Value :: !Bool -> WithDefault (b :: Bool)

Files

Agda.cabal +115/−42
CHANGELOG.md +1250/−4
LICENSE +54/−0
README.md +5/−5
Setup.hs +11/−8
doc/release-notes/2.6.1.3.md +4/−0
doc/release-notes/2.6.1.md +8/−4
doc/user-manual.pdf binary
src/agda-mode/Main.hs +1/−2
src/data/Agda.css +2/−0
src/data/JS/agda-rts.js +274/−116
src/data/JS/highlight-hover.js +32/−0
src/data/MAlonzo/src/MAlonzo/RTE.hs +10/−66
src/data/MAlonzo/src/MAlonzo/RTE/Float.hs +274/−0
src/data/agda.sty +4/−0
src/data/emacs-mode/agda-input.el +59/−65
src/data/emacs-mode/agda2-abbrevs.el +1/−0
src/data/emacs-mode/agda2-highlight.el +14/−0
src/data/emacs-mode/agda2-mode-pkg.el +3/−2
src/data/emacs-mode/agda2-mode.el +86/−37
src/data/emacs-mode/agda2-queue.el +1/−0
src/data/emacs-mode/agda2.el +1/−0
src/data/emacs-mode/annotation.el +14/−6
src/data/emacs-mode/eri.el +8/−2
src/data/lib/prim/Agda/Builtin/Bool.agda +0/−2
src/data/lib/prim/Agda/Builtin/Coinduction.agda +1/−1
src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda +0/−2
src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda +10/−4
src/data/lib/prim/Agda/Builtin/Float.agda +197/−27
src/data/lib/prim/Agda/Builtin/List.agda +0/−1
src/data/lib/prim/Agda/Builtin/Maybe.agda +10/−0
src/data/lib/prim/Agda/Builtin/Reflection.agda +64/−27
src/data/lib/prim/Agda/Builtin/Reflection/External.agda +15/−0
src/data/lib/prim/Agda/Builtin/Size.agda +7/−7
src/data/lib/prim/Agda/Builtin/String.agda +10/−1
src/data/lib/prim/Agda/Builtin/String/Properties.agda +1/−0
src/data/lib/prim/Agda/Primitive.agda +7/−3
src/full/Agda/Auto/Auto.hs +20/−18
src/full/Agda/Auto/CaseSplit.hs +61/−52
src/full/Agda/Auto/Convert.hs +22/−26
src/full/Agda/Auto/NarrowingSearch.hs +77/−67
src/full/Agda/Auto/Options.hs +1/−1
src/full/Agda/Auto/SearchControl.hs +23/−20
src/full/Agda/Auto/Syntax.hs +19/−19
src/full/Agda/Auto/Typecheck.hs +5/−6
src/full/Agda/Benchmarking.hs +8/−2
src/full/Agda/Compiler/Backend.hs +69/−30
src/full/Agda/Compiler/Backend.hs-boot +4/−0
src/full/Agda/Compiler/Builtin.hs +22/−0
src/full/Agda/Compiler/Builtin.hs-boot +5/−0
src/full/Agda/Compiler/CallCompiler.hs +2/−3
src/full/Agda/Compiler/Common.hs +47/−57
src/full/Agda/Compiler/JS/Compiler.hs +446/−155
src/full/Agda/Compiler/JS/Pretty.hs +253/−66
src/full/Agda/Compiler/JS/Substitution.hs +5/−1
src/full/Agda/Compiler/JS/Syntax.hs +76/−31
src/full/Agda/Compiler/MAlonzo/Coerce.hs +7/−3
src/full/Agda/Compiler/MAlonzo/Compiler.hs +407/−240
src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot +0/−8
src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs +35/−27
src/full/Agda/Compiler/MAlonzo/Misc.hs +99/−17
src/full/Agda/Compiler/MAlonzo/Pragmas.hs +22/−19
src/full/Agda/Compiler/MAlonzo/Pretty.hs +6/−1
src/full/Agda/Compiler/MAlonzo/Primitives.hs +137/−121
src/full/Agda/Compiler/ToTreeless.hs +149/−55
src/full/Agda/Compiler/Treeless/Builtin.hs +19/−25
src/full/Agda/Compiler/Treeless/EliminateDefaults.hs +13/−14
src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs +22/−22
src/full/Agda/Compiler/Treeless/Erase.hs +39/−29
src/full/Agda/Compiler/Treeless/GuardsToPrims.hs +10/−10
src/full/Agda/Compiler/Treeless/NormalizeNames.hs +16/−21
src/full/Agda/Compiler/Treeless/Pretty.hs +4/−4
src/full/Agda/Compiler/Treeless/Simplify.hs +35/−15
src/full/Agda/Compiler/Treeless/Subst.hs +20/−20
src/full/Agda/Compiler/Treeless/Uncase.hs +4/−2
src/full/Agda/Compiler/Treeless/Unused.hs +41/−20
src/full/Agda/ImpossibleTest.hs +18/−3
src/full/Agda/Interaction/Base.hs +35/−15
src/full/Agda/Interaction/BasicOps.hs +180/−152
src/full/Agda/Interaction/CommandLine.hs +113/−63
src/full/Agda/Interaction/EmacsCommand.hs +8/−8
src/full/Agda/Interaction/EmacsTop.hs +11/−9
src/full/Agda/Interaction/ExitCode.hs +34/−0
src/full/Agda/Interaction/FindFile.hs +31/−15
src/full/Agda/Interaction/Highlighting/Common.hs +1/−1
src/full/Agda/Interaction/Highlighting/Dot.hs +4/−95
src/full/Agda/Interaction/Highlighting/Dot/Backend.hs +160/−0
src/full/Agda/Interaction/Highlighting/Dot/Base.hs +128/−0
src/full/Agda/Interaction/Highlighting/Emacs.hs +8/−4
src/full/Agda/Interaction/Highlighting/FromAbstract.hs +699/−0
src/full/Agda/Interaction/Highlighting/Generate.hs +339/−639
src/full/Agda/Interaction/Highlighting/HTML.hs +4/−367
src/full/Agda/Interaction/Highlighting/HTML/Backend.hs +201/−0
src/full/Agda/Interaction/Highlighting/HTML/Base.hs +424/−0
src/full/Agda/Interaction/Highlighting/JSON.hs +1/−1
src/full/Agda/Interaction/Highlighting/LaTeX.hs +5/−753
src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs +191/−0
src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs +824/−0
src/full/Agda/Interaction/Highlighting/Precise.hs +276/−227
src/full/Agda/Interaction/Highlighting/Range.hs +35/−14
src/full/Agda/Interaction/Highlighting/Vim.hs +18/−14
src/full/Agda/Interaction/Imports.hs +1217/−1205
src/full/Agda/Interaction/Imports.hs-boot +3/−13
src/full/Agda/Interaction/InteractionTop.hs +185/−146
src/full/Agda/Interaction/JSON.hs +1/−2
src/full/Agda/Interaction/JSONTop.hs +110/−60
src/full/Agda/Interaction/Library.hs +207/−160
src/full/Agda/Interaction/Library/Base.hs +230/−1
src/full/Agda/Interaction/Library/Parse.hs +11/−17
src/full/Agda/Interaction/MakeCase.hs +186/−132
src/full/Agda/Interaction/Monad.hs +40/−5
src/full/Agda/Interaction/Options.hs +7/−1173
src/full/Agda/Interaction/Options/Base.hs +1146/−0
src/full/Agda/Interaction/Options/HasOptions.hs +39/−0
src/full/Agda/Interaction/Options/Help.hs +10/−2
src/full/Agda/Interaction/Options/IORefs.hs +0/−18
src/full/Agda/Interaction/Options/Lenses.hs +24/−16
src/full/Agda/Interaction/Options/Warnings.hs +89/−16
src/full/Agda/Interaction/Response.hs +3/−2
src/full/Agda/Interaction/SearchAbout.hs +8/−6
src/full/Agda/Main.hs +150/−96
src/full/Agda/Main.hs-boot +0/−5
src/full/Agda/Syntax/Abstract.hs +270/−372
src/full/Agda/Syntax/Abstract/Name.hs +72/−64
src/full/Agda/Syntax/Abstract/Pattern.hs +69/−54
src/full/Agda/Syntax/Abstract/PatternSynonyms.hs +10/−12
src/full/Agda/Syntax/Abstract/Pretty.hs +5/−5
src/full/Agda/Syntax/Abstract/Views.hs +345/−129
src/full/Agda/Syntax/Builtin.hs +44/−6
src/full/Agda/Syntax/Common.hs +571/−132
src/full/Agda/Syntax/Concrete.hs +422/−278
src/full/Agda/Syntax/Concrete/Attribute.hs +26/−2
src/full/Agda/Syntax/Concrete/Definitions.hs +1427/−1914
src/full/Agda/Syntax/Concrete/Definitions/Errors.hs +364/−0
src/full/Agda/Syntax/Concrete/Definitions/Monad.hs +248/−0
src/full/Agda/Syntax/Concrete/Definitions/Types.hs +315/−0
src/full/Agda/Syntax/Concrete/Fixity.hs +43/−36
src/full/Agda/Syntax/Concrete/Generic.hs +99/−76
src/full/Agda/Syntax/Concrete/Glyph.hs +116/−0
src/full/Agda/Syntax/Concrete/Name.hs +149/−100
src/full/Agda/Syntax/Concrete/Operators.hs +184/−115
src/full/Agda/Syntax/Concrete/Operators/Parser.hs +48/−49
src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs +1/−2
src/full/Agda/Syntax/Concrete/Pattern.hs +39/−38
src/full/Agda/Syntax/Concrete/Pretty.hs +138/−157
src/full/Agda/Syntax/DoNotation.hs +62/−51
src/full/Agda/Syntax/Fixity.hs +8/−8
src/full/Agda/Syntax/IdiomBrackets.hs +12/−11
src/full/Agda/Syntax/Info.hs +36/−16
src/full/Agda/Syntax/Internal.hs +183/−341
src/full/Agda/Syntax/Internal/Blockers.hs +271/−0
src/full/Agda/Syntax/Internal/Defs.hs +6/−13
src/full/Agda/Syntax/Internal/Elim.hs +83/−0
src/full/Agda/Syntax/Internal/Generic.hs +22/−28
src/full/Agda/Syntax/Internal/MetaVars.hs +60/−13
src/full/Agda/Syntax/Internal/Names.hs +133/−118
src/full/Agda/Syntax/Internal/Pattern.hs +47/−34
src/full/Agda/Syntax/Internal/SanityCheck.hs +2/−2
src/full/Agda/Syntax/Literal.hs +54/−99
src/full/Agda/Syntax/Notation.hs +50/−32
src/full/Agda/Syntax/Parser.hs +93/−61
src/full/Agda/Syntax/Parser/Alex.hs +19/−3
src/full/Agda/Syntax/Parser/Comments.hs +7/−6
src/full/Agda/Syntax/Parser/Layout.hs +181/−75
src/full/Agda/Syntax/Parser/Layout.hs-boot +8/−3
src/full/Agda/Syntax/Parser/LexActions.hs +83/−50
src/full/Agda/Syntax/Parser/LexActions.hs-boot +6/−3
src/full/Agda/Syntax/Parser/Lexer.x +31/−25
src/full/Agda/Syntax/Parser/Literate.hs +13/−13
src/full/Agda/Syntax/Parser/LookAhead.hs +3/−2
src/full/Agda/Syntax/Parser/Monad.hs +105/−49
src/full/Agda/Syntax/Parser/Parser.y +2410/−2361
src/full/Agda/Syntax/Parser/StringLiterals.hs +10/−11
src/full/Agda/Syntax/Parser/Tokens.hs +25/−10
src/full/Agda/Syntax/Position.hs +68/−96
src/full/Agda/Syntax/Reflected.hs +22/−5
src/full/Agda/Syntax/Scope/Base.hs +244/−113
src/full/Agda/Syntax/Scope/Monad.hs +202/−104
src/full/Agda/Syntax/Translation/AbstractToConcrete.hs +347/−228
src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +3063/−2720
src/full/Agda/Syntax/Translation/InternalToAbstract.hs +307/−214
src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs +174/−75
src/full/Agda/Syntax/Treeless.hs +69/−13
src/full/Agda/Termination/CallGraph.hs +8/−3
src/full/Agda/Termination/CallMatrix.hs +0/−3
src/full/Agda/Termination/CutOff.hs +15/−3
src/full/Agda/Termination/Monad.hs +17/−12
src/full/Agda/Termination/Order.hs +3/−3
src/full/Agda/Termination/RecCheck.hs +2/−5
src/full/Agda/Termination/SparseMatrix.hs +0/−2
src/full/Agda/Termination/TermCheck.hs +68/−55
src/full/Agda/TypeChecking/Abstract.hs +71/−45
src/full/Agda/TypeChecking/CheckInternal.hs +73/−96
src/full/Agda/TypeChecking/CheckInternal.hs-boot +3/−10
src/full/Agda/TypeChecking/CompiledClause.hs +21/−14
src/full/Agda/TypeChecking/CompiledClause/Compile.hs +4/−7
src/full/Agda/TypeChecking/CompiledClause/Match.hs +5/−6
src/full/Agda/TypeChecking/Constraints.hs +78/−61
src/full/Agda/TypeChecking/Constraints.hs-boot +4/−2
src/full/Agda/TypeChecking/Conversion.hs +394/−390
src/full/Agda/TypeChecking/Conversion.hs-boot +2/−9
src/full/Agda/TypeChecking/Conversion/Pure.hs +60/−34
src/full/Agda/TypeChecking/Coverage.hs +114/−92
src/full/Agda/TypeChecking/Coverage/Match.hs +34/−31
src/full/Agda/TypeChecking/Coverage/SplitTree.hs +12/−5
src/full/Agda/TypeChecking/Datatypes.hs +22/−83
src/full/Agda/TypeChecking/DeadCode.hs +5/−6
src/full/Agda/TypeChecking/DisplayForm.hs +84/−51
src/full/Agda/TypeChecking/DropArgs.hs +4/−4
src/full/Agda/TypeChecking/Empty.hs +19/−13
src/full/Agda/TypeChecking/Errors.hs +174/−101
src/full/Agda/TypeChecking/EtaContract.hs +15/−18
src/full/Agda/TypeChecking/EtaExpand.hs +3/−11
src/full/Agda/TypeChecking/Forcing.hs +43/−57
src/full/Agda/TypeChecking/Free.hs +2/−8
src/full/Agda/TypeChecking/Free/Lazy.hs +28/−35
src/full/Agda/TypeChecking/Free/Precompute.hs +4/−12
src/full/Agda/TypeChecking/Free/Reduce.hs +18/−23
src/full/Agda/TypeChecking/Functions.hs +6/−6
src/full/Agda/TypeChecking/Generalize.hs +81/−49
src/full/Agda/TypeChecking/IApplyConfluence.hs +9/−15
src/full/Agda/TypeChecking/Implicit.hs +69/−8
src/full/Agda/TypeChecking/Injectivity.hs +23/−24
src/full/Agda/TypeChecking/InstanceArguments.hs +119/−84
src/full/Agda/TypeChecking/Irrelevance.hs +113/−65
src/full/Agda/TypeChecking/Irrelevance.hs-boot +5/−2
src/full/Agda/TypeChecking/Level.hs +20/−28
src/full/Agda/TypeChecking/Level/Solve.hs +7/−9
src/full/Agda/TypeChecking/LevelConstraints.hs +5/−6
src/full/Agda/TypeChecking/Lock.hs +134/−0
src/full/Agda/TypeChecking/Lock.hs-boot +35/−0
src/full/Agda/TypeChecking/MetaVars.hs +240/−156
src/full/Agda/TypeChecking/MetaVars/Mention.hs +21/−19
src/full/Agda/TypeChecking/MetaVars/Occurs.hs +148/−111
src/full/Agda/TypeChecking/Monad.hs +2/−0
src/full/Agda/TypeChecking/Monad/Base.hs +4730/−4314
src/full/Agda/TypeChecking/Monad/Base.hs-boot +0/−2
src/full/Agda/TypeChecking/Monad/Benchmark.hs +1/−0
src/full/Agda/TypeChecking/Monad/Builtin.hs +95/−44
src/full/Agda/TypeChecking/Monad/Builtin.hs-boot +4/−1
src/full/Agda/TypeChecking/Monad/Caching.hs +11/−6
src/full/Agda/TypeChecking/Monad/Constraints.hs +50/−34
src/full/Agda/TypeChecking/Monad/Context.hs +71/−53
src/full/Agda/TypeChecking/Monad/Context.hs-boot +26/−0
src/full/Agda/TypeChecking/Monad/Debug.hs +85/−85
src/full/Agda/TypeChecking/Monad/Env.hs +3/−14
src/full/Agda/TypeChecking/Monad/Imports.hs +40/−16
src/full/Agda/TypeChecking/Monad/MetaVars.hs +72/−48
src/full/Agda/TypeChecking/Monad/MetaVars.hs-boot +13/−1
src/full/Agda/TypeChecking/Monad/Mutual.hs +0/−1
src/full/Agda/TypeChecking/Monad/Open.hs +44/−10
src/full/Agda/TypeChecking/Monad/Options.hs +65/−45
src/full/Agda/TypeChecking/Monad/Pure.hs +41/−0
src/full/Agda/TypeChecking/Monad/Pure.hs-boot +29/−0
src/full/Agda/TypeChecking/Monad/Signature.hs +152/−108
src/full/Agda/TypeChecking/Monad/Signature.hs-boot +0/−1
src/full/Agda/TypeChecking/Monad/SizedTypes.hs +38/−16
src/full/Agda/TypeChecking/Monad/State.hs +16/−15
src/full/Agda/TypeChecking/Monad/Statistics.hs +0/−4
src/full/Agda/TypeChecking/Monad/Trace.hs +141/−121
src/full/Agda/TypeChecking/Names.hs +9/−9
src/full/Agda/TypeChecking/Patterns/Abstract.hs +25/−14
src/full/Agda/TypeChecking/Patterns/Internal.hs +0/−1
src/full/Agda/TypeChecking/Patterns/Match.hs +53/−34
src/full/Agda/TypeChecking/Patterns/Match.hs-boot +6/−4
src/full/Agda/TypeChecking/Polarity.hs +141/−96
src/full/Agda/TypeChecking/Polarity.hs-boot +12/−2
src/full/Agda/TypeChecking/Positivity.hs +36/−50
src/full/Agda/TypeChecking/Positivity/Occurrence.hs +7/−5
src/full/Agda/TypeChecking/Pretty.hs +124/−164
src/full/Agda/TypeChecking/Pretty.hs-boot +16/−12
src/full/Agda/TypeChecking/Pretty/Call.hs +10/−2
src/full/Agda/TypeChecking/Pretty/Constraint.hs +143/−0
src/full/Agda/TypeChecking/Pretty/Constraint.hs-boot +9/−0
src/full/Agda/TypeChecking/Pretty/Warning.hs +254/−97
src/full/Agda/TypeChecking/Pretty/Warning.hs-boot +3/−3
src/full/Agda/TypeChecking/Primitive.hs +252/−121
src/full/Agda/TypeChecking/Primitive/Base.hs +43/−28
src/full/Agda/TypeChecking/Primitive/Cubical.hs +265/−268
src/full/Agda/TypeChecking/ProjectionLike.hs +29/−23
src/full/Agda/TypeChecking/Quote.hs +111/−46
src/full/Agda/TypeChecking/ReconstructParameters.hs +116/−11
src/full/Agda/TypeChecking/RecordPatterns.hs +20/−23
src/full/Agda/TypeChecking/Records.hs +155/−100
src/full/Agda/TypeChecking/Reduce.hs +283/−250
src/full/Agda/TypeChecking/Reduce.hs-boot +6/−0
src/full/Agda/TypeChecking/Reduce/Fast.hs +102/−86
src/full/Agda/TypeChecking/Reduce/Monad.hs +7/−5
src/full/Agda/TypeChecking/Rewriting.hs +83/−56
src/full/Agda/TypeChecking/Rewriting.hs-boot +1/−1
src/full/Agda/TypeChecking/Rewriting/Clause.hs +5/−4
src/full/Agda/TypeChecking/Rewriting/Confluence.hs +408/−149
src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs +78/−43
src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs +17/−14
src/full/Agda/TypeChecking/Rules/Application.hs +310/−136
src/full/Agda/TypeChecking/Rules/Application.hs-boot +4/−4
src/full/Agda/TypeChecking/Rules/Builtin.hs +150/−80
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs +6/−5
src/full/Agda/TypeChecking/Rules/Data.hs +84/−87
src/full/Agda/TypeChecking/Rules/Decl.hs +87/−65
src/full/Agda/TypeChecking/Rules/Def.hs +239/−143
src/full/Agda/TypeChecking/Rules/Display.hs +33/−13
src/full/Agda/TypeChecking/Rules/LHS.hs +464/−235
src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs +13/−6
src/full/Agda/TypeChecking/Rules/LHS/Problem.hs +52/−32
src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs +9/−4
src/full/Agda/TypeChecking/Rules/LHS/Unify.hs +206/−164
src/full/Agda/TypeChecking/Rules/Record.hs +94/−64
src/full/Agda/TypeChecking/Rules/Term.hs +365/−301
src/full/Agda/TypeChecking/Rules/Term.hs-boot +2/−1
src/full/Agda/TypeChecking/Serialise.hs +29/−27
src/full/Agda/TypeChecking/Serialise/Base.hs +15/−10
src/full/Agda/TypeChecking/Serialise/Instances.hs +18/−8
src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs +24/−2
src/full/Agda/TypeChecking/Serialise/Instances/Common.hs +96/−67
src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs +171/−91
src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs +13/−3
src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs +49/−34
src/full/Agda/TypeChecking/SizedTypes.hs +71/−54
src/full/Agda/TypeChecking/SizedTypes/Solve.hs +50/−49
src/full/Agda/TypeChecking/SizedTypes/Syntax.hs +20/−16
src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs +13/−11
src/full/Agda/TypeChecking/Sort.hs +50/−28
src/full/Agda/TypeChecking/Substitute.hs +310/−219
src/full/Agda/TypeChecking/Substitute/Class.hs +48/−35
src/full/Agda/TypeChecking/Substitute/DeBruijn.hs +0/−9
src/full/Agda/TypeChecking/SyntacticEquality.hs +13/−32
src/full/Agda/TypeChecking/Telescope.hs +58/−47
src/full/Agda/TypeChecking/Telescope.hs-boot +6/−1
src/full/Agda/TypeChecking/Telescope/Path.hs +44/−9
src/full/Agda/TypeChecking/Unquote.hs +339/−98
src/full/Agda/TypeChecking/Warnings.hs +72/−36
src/full/Agda/TypeChecking/Warnings.hs-boot +0/−13
src/full/Agda/TypeChecking/With.hs +109/−71
src/full/Agda/Utils/Applicative.hs +18/−0
src/full/Agda/Utils/Bag.hs +2/−2
src/full/Agda/Utils/Benchmark.hs +57/−21
src/full/Agda/Utils/BiMap.hs +405/−34
src/full/Agda/Utils/CallStack.hs +3/−0
src/full/Agda/Utils/CallStack/Base.hs +140/−0
src/full/Agda/Utils/CallStack/Pretty.hs +32/−0
src/full/Agda/Utils/Char.hs +36/−0
src/full/Agda/Utils/Cluster.hs +0/−1
src/full/Agda/Utils/Either.hs +21/−18
src/full/Agda/Utils/Empty.hs +8/−3
src/full/Agda/Utils/Environment.hs +21/−11
src/full/Agda/Utils/Except.hs +0/−37
src/full/Agda/Utils/Fail.hs +1/−2
src/full/Agda/Utils/Favorites.hs +0/−2
src/full/Agda/Utils/FileName.hs +45/−40
src/full/Agda/Utils/Float.hs +293/−31
src/full/Agda/Utils/Functor.hs +1/−1
src/full/Agda/Utils/Geniplate.hs +0/−54
src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs +0/−3
src/full/Agda/Utils/Graph/TopSort.hs +2/−8
src/full/Agda/Utils/Haskell/Syntax.hs +4/−1
src/full/Agda/Utils/IO.hs +6/−0
src/full/Agda/Utils/IO/TempFile.hs +0/−2
src/full/Agda/Utils/Impossible.hs +32/−30
src/full/Agda/Utils/Lens.hs +0/−2
src/full/Agda/Utils/List.hs +81/−13
src/full/Agda/Utils/List1.hs +162/−0
src/full/Agda/Utils/List2.hs +79/−0
src/full/Agda/Utils/ListT.hs +23/−9
src/full/Agda/Utils/Map.hs +22/−3
src/full/Agda/Utils/Maybe.hs +9/−12
src/full/Agda/Utils/Maybe/Strict.hs +1/−3
src/full/Agda/Utils/Monad.hs +21/−25
src/full/Agda/Utils/Monoid.hs +6/−2
src/full/Agda/Utils/Null.hs +10/−2
src/full/Agda/Utils/Permutation.hs +18/−16
src/full/Agda/Utils/Pointer.hs +0/−2
src/full/Agda/Utils/Pretty.hs +76/−9
src/full/Agda/Utils/RangeMap.hs +370/−0
src/full/Agda/Utils/Semigroup.hs +20/−0
src/full/Agda/Utils/Singleton.hs +30/−1
src/full/Agda/Utils/Size.hs +20/−37
src/full/Agda/Utils/SmallSet.hs +3/−4
src/full/Agda/Utils/String.hs +3/−22
src/full/Agda/Utils/Suffix.hs +12/−22
src/full/Agda/Utils/Time.hs +2/−2
src/full/Agda/Utils/Trie.hs +5/−6
src/full/Agda/Utils/Tuple.hs +6/−6
src/full/Agda/Utils/TypeLevel.hs +1/−2
src/full/Agda/Utils/TypeLits.hs +1/−1
src/full/Agda/Utils/Update.hs +18/−3
src/full/Agda/Utils/Warshall.hs +34/−30
src/full/Agda/Utils/WithDefault.hs +11/−5
src/full/Agda/Utils/Zipper.hs +0/−3
src/full/Agda/Version.hs +16/−3
src/full/Agda/VersionCommit.hs +8/−5
src/main/Main.hs +2/−2
stack-8.0.2.yaml +12/−1
stack-8.10.3.yaml +0/−3
stack-8.10.5.yaml +3/−0
stack-8.2.2.yaml +8/−1
stack-8.4.4.yaml +5/−2
stack-8.6.5.yaml +6/−2
stack-8.8.3.yaml +0/−11
stack-8.8.4.yaml +5/−0
stack-9.0.1.yaml +93/−0

Agda.cabal view

@@ -1,10 +1,10 @@ name:            Agda-version:         2.6.1.3+version:         2.6.2 cabal-version:   >= 1.10 build-type:      Custom license:         OtherLicense license-file:    LICENSE-copyright:       (c) 2005-2020 The Agda Team.+copyright:       (c) 2005-2021 The Agda Team. author:          Ulf Norell and The Agda Team, see https://agda.readthedocs.io/en/latest/team.html maintainer:      Ulf Norell <ulfn@chalmers.se> homepage:        http://wiki.portal.chalmers.se/agda/@@ -39,10 +39,12 @@                     GHC == 8.4.4                     GHC == 8.6.5                     GHC == 8.8.4-                    GHC == 8.10.3+                    GHC == 8.10.5+                    GHC == 9.0.1  extra-source-files: CHANGELOG.md                     README.md+                    doc/release-notes/2.6.1.3.md                     doc/release-notes/2.6.1.2.md                     doc/release-notes/2.6.1.1.md                     doc/release-notes/2.6.1.md@@ -76,13 +78,13 @@                     doc/release-notes/2.2.4.md                     doc/release-notes/2.2.0.md                     doc/user-manual.pdf-                    stack-8.10.3.yaml-                    stack-8.8.4.yaml-                    stack-8.8.3.yaml-                    stack-8.6.5.yaml-                    stack-8.4.4.yaml-                    stack-8.2.2.yaml                     stack-8.0.2.yaml+                    stack-8.2.2.yaml+                    stack-8.4.4.yaml+                    stack-8.6.5.yaml+                    stack-8.8.4.yaml+                    stack-8.10.5.yaml+                    stack-9.0.1.yaml  data-dir:           src/data data-files:         Agda.css@@ -90,6 +92,7 @@                     emacs-mode/*.el                     JS/agda-rts.js                     JS/biginteger.js+                    JS/highlight-hover.js                     lib/prim/Agda/Builtin/Bool.agda                     lib/prim/Agda/Builtin/Char.agda                     lib/prim/Agda/Builtin/Char/Properties.agda@@ -110,8 +113,10 @@                     lib/prim/Agda/Builtin/IO.agda                     lib/prim/Agda/Builtin/Int.agda                     lib/prim/Agda/Builtin/List.agda+                    lib/prim/Agda/Builtin/Maybe.agda                     lib/prim/Agda/Builtin/Nat.agda                     lib/prim/Agda/Builtin/Reflection.agda+                    lib/prim/Agda/Builtin/Reflection/External.agda                     lib/prim/Agda/Builtin/Reflection/Properties.agda                     lib/prim/Agda/Builtin/Sigma.agda                     lib/prim/Agda/Builtin/Size.agda@@ -125,6 +130,7 @@                     lib/prim/Agda/Primitive.agda                     lib/prim/Agda/Primitive/Cubical.agda                     MAlonzo/src/MAlonzo/*.hs+                    MAlonzo/src/MAlonzo/RTE/*.hs                     postprocess-latex.pl  source-repository head@@ -134,7 +140,7 @@ source-repository this   type:     git   location: https://github.com/agda/agda.git-  tag:      v2.6.1.3+  tag:      v2.6.2  flag cpphs   default:     False@@ -153,10 +159,15 @@     Enable the --count-clusters flag. (If enable-cluster-counting is     False, then the --count-clusters flag triggers an error message.) +flag optimise-heavily+  default: False+  description:+    Enable some expensive optimisations when compiling Agda.+ custom-setup-  setup-depends:  base >= 4.9.0.0 && < 4.15-                , Cabal >= 1.24.0.0 && < 3.3-                , directory >= 1.2.6.2 && < 1.4+  setup-depends:  base >= 4.9.0.0 && < 4.16+                , Cabal >= 1.24.0.0 && < 3.5+                , directory >= 1.2.6.1.2 && < 1.4                 , filepath >= 1.4.1.0 && < 1.5                 , process >= 1.4.2.0 && < 1.7 @@ -175,10 +186,10 @@    if flag(enable-cluster-counting)     cpp-options:    -DCOUNT_CLUSTERS-    build-depends:  text-icu == 0.7.*+    build-depends:  text-icu >= 0.7.1.0    if os(windows)-    build-depends:  Win32 >= 2.3.1.1 && < 2.7+    build-depends:  Win32 >= 2.3.1.1 && < 2.13    -- Agda cannot be built with GHC 8.6.1 due to a compiler bug, see   -- Agda Issue #3344.@@ -193,12 +204,14 @@   build-depends:  aeson >= 1.1.2.0 && < 1.6                 , array >= 0.5.1.1 && < 0.6                 , async >= 2.2 && < 2.3-                , base >= 4.9.0.0 && < 4.15+                , base >= 4.9.0.0 && < 4.16                 , binary >= 0.8.3.0 && < 0.9                 , blaze-html >= 0.8 && < 0.10                 , boxes >= 0.1.3 && < 0.2-                , bytestring >= 0.10.8.1 && < 0.11-                , containers >= 0.5.7.1 && < 0.7+                , bytestring >= 0.10.8.1 && < 0.12+                , case-insensitive >= 1.2.0.4 && < 1.3+                -- containers-0.5.11.0 is the first to contain IntSet.intersection+                , containers >= 0.5.11.0 && < 0.7                 , data-hash >= 0.2.0.0 && < 0.3                 , deepseq >= 1.4.2.0 && < 1.5                 , directory >= 1.2.6.2 && < 1.4@@ -207,7 +220,6 @@                 -- exceptions-0.8 instead of 0.10 because of stack                 , exceptions >= 0.8 && < 0.11                 , filepath >= 1.4.1.0 && < 1.5-                , geniplate-mirror >= 0.6.0.6 && < 0.8                 , gitrev >= 1.3.1 && < 2.0                 -- hashable 1.2.0.10 makes library-test 10x                 -- slower. The issue was fixed in hashable 1.2.1.0.@@ -220,31 +232,45 @@                 -- some cases.                 , hashtables >= 1.2.0.2 && < 1.3                 , haskeline >= 0.7.2.3 && < 0.9-                , ieee754 >= 0.7.8 && < 0.9+                -- monad-control-1.0.1.0 is the first to contain liftThrough+                , monad-control >= 1.0.1.0 && < 1.1                 -- mtl-2.1 contains a severe bug.                 --                 -- mtl >= 2.2 && < 2.2.1 doesn't export Control.Monad.Except.+                -- Need mtl 2.2.2  for export of Control.Monad.IdentityT (ghc 8.2.2+)                 , mtl >= 2.2.1 && < 2.3                 , murmur-hash >= 0.1 && < 0.2+                , parallel >= 3.2.2.0 && < 3.3                 , pretty >= 1.1.3.3 && < 1.2                 , process >= 1.4.2.0 && < 1.7                 , regex-tdfa >= 1.3.1.0 && < 1.4                 , split >= 0.2.0.0 && < 0.2.4                 , stm >= 2.4.4 && < 2.6                 , strict >= 0.3.2 && < 0.5-                , template-haskell >= 2.11.0.0 && < 2.17-                , time >= 1.6.0.1 && < 1.10+                , template-haskell >= 2.11.0.0 && < 2.18+                , text >= 1.2.3.0 && < 1.3+                , time >= 1.6.0.1 && < 1.12+                , transformers == 0.5.*                 , unordered-containers >= 0.2.5.0 && < 0.3                 , uri-encode >= 1.5.0.4 && < 1.6                 , zlib == 0.6.* -  -- In hTags the mtl library must be compiled with the version of+  -- Andreas, 2021-03-10:+  -- All packages we depend upon should be mentioned in an unconditional+  -- build-depends field, but additional restrictions on their+  -- version for specific GHCs may be placed in conditionals.+  --+  -- The goal is to be able to make (e.g. when a new GHC comes out)+  -- revisions on hackage, e.g. relaxing upper bounds.  This process+  -- currently does not support revising conditionals.++  -- In hs-tags the mtl library must be compiled with the version of   -- transformers shipped with GHC, so we use that version in Agda (see,   -- for example, Issue #2983).-  if impl(ghc > 8.10.3)+  if impl(ghc > 9.0.1)     build-depends: transformers >= 0.5.6.2 -  if impl(ghc >= 8.6.4) && impl(ghc <= 8.10.3)+  if impl(ghc >= 8.6.4) && impl(ghc <= 9.0.1)     build-depends: transformers == 0.5.6.2    if impl(ghc >= 8.4) && impl(ghc < 8.6.4)@@ -253,12 +279,12 @@   if impl(ghc < 8.4)     build-depends: transformers == 0.5.2.0 -  -- ASR (2018-10-16). Required for supporting GHC 8.4.1, 8.4.2 and+  -- ASR (2018-10-16).+  -- text-1.2.3.0 required for supporting GHC 8.4.1, 8.4.2 and   -- 8.4.3. See Issue #3277.-  if impl(ghc >= 8.4.1) && impl(ghc <= 8.4.3)-    build-depends: text >= 1.2.3.0 && < 1.3-  else-    build-depends: text >= 1.2.3.1 && < 1.3+  -- The other GHC versions can be restricted to >= 1.2.3.1.+  if impl(ghc < 8.4.1) || impl(ghc > 8.4.3)+    build-depends: text >= 1.2.3.1    if impl(ghc >= 8.4)     build-depends: ghc-compact == 0.1.*@@ -279,6 +305,7 @@                     Agda.Auto.Typecheck                     Agda.Benchmarking                     Agda.Compiler.Backend+                    Agda.Compiler.Builtin                     Agda.Compiler.CallCompiler                     Agda.Compiler.Common                     Agda.Compiler.JS.Compiler@@ -316,12 +343,14 @@                     Agda.Interaction.CommandLine                     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                     Agda.Interaction.Highlighting.Emacs+                    Agda.Interaction.Highlighting.FromAbstract                     Agda.Interaction.Highlighting.Generate                     Agda.Interaction.Highlighting.HTML                     Agda.Interaction.Highlighting.JSON@@ -339,7 +368,6 @@                     Agda.Interaction.Library.Parse                     Agda.Interaction.Options                     Agda.Interaction.Options.Help-                    Agda.Interaction.Options.IORefs                     Agda.Interaction.Options.Lenses                     Agda.Interaction.Options.Warnings                     Agda.Main@@ -353,8 +381,12 @@                     Agda.Syntax.Common                     Agda.Syntax.Concrete.Attribute                     Agda.Syntax.Concrete.Definitions+                    Agda.Syntax.Concrete.Definitions.Errors+                    Agda.Syntax.Concrete.Definitions.Monad+                    Agda.Syntax.Concrete.Definitions.Types                     Agda.Syntax.Concrete.Fixity                     Agda.Syntax.Concrete.Generic+                    Agda.Syntax.Concrete.Glyph                     Agda.Syntax.Concrete.Name                     Agda.Syntax.Concrete.Operators.Parser                     Agda.Syntax.Concrete.Operators.Parser.Monad@@ -367,7 +399,9 @@                     Agda.Syntax.IdiomBrackets                     Agda.Syntax.Info                     Agda.Syntax.Internal+                    Agda.Syntax.Internal.Blockers                     Agda.Syntax.Internal.Defs+                    Agda.Syntax.Internal.Elim                     Agda.Syntax.Internal.Generic                     Agda.Syntax.Internal.MetaVars                     Agda.Syntax.Internal.Names@@ -441,6 +475,7 @@                     Agda.TypeChecking.Irrelevance                     Agda.TypeChecking.Level                     Agda.TypeChecking.LevelConstraints+                    Agda.TypeChecking.Lock                     Agda.TypeChecking.Level.Solve                     Agda.TypeChecking.MetaVars                     Agda.TypeChecking.MetaVars.Mention@@ -459,6 +494,7 @@                     Agda.TypeChecking.Monad.Mutual                     Agda.TypeChecking.Monad.Open                     Agda.TypeChecking.Monad.Options+                    Agda.TypeChecking.Monad.Pure                     Agda.TypeChecking.Monad.Signature                     Agda.TypeChecking.Monad.SizedTypes                     Agda.TypeChecking.Monad.State@@ -474,6 +510,7 @@                     Agda.TypeChecking.Positivity.Occurrence                     Agda.TypeChecking.Pretty                     Agda.TypeChecking.Pretty.Call+                    Agda.TypeChecking.Pretty.Constraint                     Agda.TypeChecking.Pretty.Warning                     Agda.TypeChecking.Primitive                     Agda.TypeChecking.Primitive.Base@@ -535,10 +572,11 @@                     Agda.Utils.Bag                     Agda.Utils.Benchmark                     Agda.Utils.BiMap+                    Agda.Utils.CallStack+                    Agda.Utils.Char                     Agda.Utils.Cluster                     Agda.Utils.Empty                     Agda.Utils.Environment-                    Agda.Utils.Except                     Agda.Utils.Either                     Agda.Utils.Fail                     Agda.Utils.Favorites@@ -546,7 +584,6 @@                     Agda.Utils.Float                     Agda.Utils.Functor                     Agda.Utils.Function-                    Agda.Utils.Geniplate                     Agda.Utils.Graph.AdjacencyMap.Unidirectional                     Agda.Utils.Graph.TopSort                     Agda.Utils.Hash@@ -563,6 +600,8 @@                     Agda.Utils.Lens                     Agda.Utils.Lens.Examples                     Agda.Utils.List+                    Agda.Utils.List1+                    Agda.Utils.List2                     Agda.Utils.ListT                     Agda.Utils.Map                     Agda.Utils.Maybe@@ -577,7 +616,9 @@                     Agda.Utils.Pointer                     Agda.Utils.POMonoid                     Agda.Utils.Pretty+                    Agda.Utils.RangeMap                     Agda.Utils.SemiRing+                    Agda.Utils.Semigroup                     Agda.Utils.Singleton                     Agda.Utils.Size                     Agda.Utils.SmallSet@@ -598,12 +639,24 @@                     Agda.VersionCommit    other-modules:    Paths_Agda+                    Agda.Interaction.Highlighting.Dot.Backend+                    Agda.Interaction.Highlighting.Dot.Base+                    Agda.Interaction.Highlighting.HTML.Backend+                    Agda.Interaction.Highlighting.HTML.Base+                    Agda.Interaction.Highlighting.LaTeX.Backend+                    Agda.Interaction.Highlighting.LaTeX.Base+                    Agda.Interaction.Options.Base+                    Agda.Interaction.Options.HasOptions+                    Agda.Utils.CallStack.Base+                    Agda.Utils.CallStack.Pretty -  -- NOTE: If adding flags, also add to `.ghci-8.0`-  if impl(ghc <= 8.0.2)+  if flag(optimise-heavily)     ghc-options: -fexpose-all-unfoldings                  -fspecialise-aggressively-                 -fprint-potential-instances++  -- NOTE: If adding flags, also add to `.ghci-8.0`+  if impl(ghc <= 8.0.2)+    ghc-options: -fprint-potential-instances                  -- Initially, we disable all the warnings.                  -w                  -- This option must be the first one after disabling the@@ -637,9 +690,7 @@                  -Wwarnings-deprecations                  -Wwrong-do-bind   else-    ghc-options: -fexpose-all-unfoldings-                 -fspecialise-aggressively-                 -fprint-potential-instances+    ghc-options: -fprint-potential-instances                  -Werror=unrecognised-warning-flags                  -Werror=deprecated-flags                  -Werror=deriving-typeable@@ -684,13 +735,33 @@                  -Werror=star-binder                  -Werror=star-is-type +  -- The following warning is an error in GHC >= 8.10.+  if impl(ghc >= 8.6) && impl(ghc < 8.10)+    ghc-options: -Werror=implicit-kind-vars++  -- NOTE: If adding or removing flags, also change `.ghci-8.8`+  if impl(ghc >= 8.8)+    ghc-options: -Werror=missed-extra-shared-lib++  -- NOTE: If adding or removing flags, also change `.ghci-8.10`+  if impl(ghc >= 8.10)+    ghc-options: -Werror=deriving-defaults+                 -Werror=redundant-record-wildcards+                 -Werror=unused-packages+                 -Werror=unused-record-wildcards++  -- NOTE: If adding or removing flags, also change `.ghci-9.0`+  if impl(ghc >= 9.0)+    ghc-options: -Werror=invalid-haddock+   default-language: Haskell2010    -- NOTE: If adding or removing default extensions, also change:   --         .ghci-8.0   --         .hlint.yaml   -- This should also use the same extensions as the `test-suite` target below.-  default-extensions: ConstraintKinds+  default-extensions: BangPatterns+                    , ConstraintKinds                     --L-T Chen (2019-07-15):                     -- Enabling DataKinds only locally makes the compile time                     -- slightly shorter, see PR #3920.@@ -699,6 +770,7 @@                     , DeriveDataTypeable                     , DeriveFoldable                     , DeriveFunctor+                    , DeriveGeneric                     , DeriveTraversable                     , ExistentialQuantification                     , FlexibleContexts@@ -717,6 +789,7 @@                     , ScopedTypeVariables                     , StandaloneDeriving                     , TupleSections+                    , TypeFamilies                     , TypeSynonymInstances  executable agda@@ -749,8 +822,8 @@   hs-source-dirs:   src/agda-mode   main-is:          Main.hs   other-modules:    Paths_Agda-  build-depends:    base >= 4.9.0.0 && < 4.15-                  , directory >= 1.2.6.2 && < 1.4+  build-depends:    base >= 4.9.0.0 && < 4.16+                  , directory >= 1.2.6.1.2 && < 1.4                   , filepath >= 1.4.1.0 && < 1.5                   , process >= 1.4.2.0 && < 1.7   default-language: Haskell2010

CHANGELOG.md view

@@ -1,4 +1,1250 @@-Release notes for Agda version 2.6.1.3-======================================--* Added support for GHC 8.10.3.+Release notes for Agda version 2.6.2+====================================++Highlights+----------++* Several improvements and bug-fixes related to [Run-time+  Irrelevance](https://agda.readthedocs.io/en/v2.6.2/language/runtime-irrelevance.html).++* Several improvements and bug-fixes related to the [JavaScript+  Backend](https://agda.readthedocs.io/en/v2.6.2/tools/compilers.html#javascript-backend).++* Added experimental support for [Guarded Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.2/language/guarded-cubical.html).++* The [Primitive+  Sorts](https://agda.readthedocs.io/en/v2.6.2/language/built-ins.html#sorts)+  of Agda (`Set` and `Prop`) are no longer keywords and can be renamed+  when importing `Agda.Primitive`.++* Added native support for the [Inspect+  Idiom](https://agda.readthedocs.io/en/v2.6.2/language/with-abstraction.html#with-abstraction-equality).++* Added support for making [System+  Calls](https://agda.readthedocs.io/en/v2.6.2/language/reflection.html#system-calls)+  from the reflection API.++Installation and infrastructure+-------------------------------++* Added support for GHC 8.10.5 and 9.0.1.++* Some expensive optimisations are now off by default+  (see [#4521](https://github.com/agda/agda/issues/4521)).++  These optimisations can in some cases make Agda substantially+  faster, but they can also make the compilation of the Agda program+  take more time and space.++  The optimisations can be turned on manually (Cabal:+  `-foptimise-heavily`, Stack: `--flag Agda:optimise-heavily`). They+  are turned on (by default) when Agda is installed using `make+  install`.++  If the optimisations are turned on it might make sense to limit+  GHC's memory usage (using something like `--ghc-options="+RTS -M6G+  -RTS"`).++Pragmas and options+-------------------++* New option `--auto-inline` turns on automatic compile-time inlining+  of simple functions. This was previously enabled by default.++  Note that the absence of automatic inlining can make typechecking+  substantially slower.++  The new default has repercussions on termination checking, for instance+  (see [#4702](https://github.com/agda/agda/issues/4702)).+  The following formulation of `plus` termination checks with `--auto-inline`+  but not without:+  ```agda+  open import Agda.Builtin.Nat++  case_of_ : {A B : Set} → A → (A → B) → B+  case x of f = f x++  plus : Nat → Nat → Nat+  plus m n = case m of λ+     { zero    → n+     ; (suc m) → suc (plus m n)+     }+  ```+  In this particular case, we can work around the limitation of the+  termination checker with pragma `{-# INLINE case_of_ #-}`.++* New options `--qualified-instances` (default) and+  `--no-qualified-instances`. When `--no-qualified-instances` is+  enabled, Agda will only consider candidates for instance search that+  are in scope under an unqualified name (see+  [#4522](https://github.com/agda/agda/pull/4522)).++* New option `--call-by-name` turns off call-by-need evaluation at type+  checking time.++* New option `--highlight-occurrences` (off by default) enables the HTML+  backend to include a JavaScript file that highlights all occurrences of+  the mouse-hovered symbol (see+  [#4535](https://github.com/agda/agda/pull/4535)).++* New option `--no-import-sorts` disables the implicit `open+  import Agda.Primitive using (Set; Prop)` at the top of each file+  (see below).++* New option `--local-confluence-check` to restore the old behaviour+  of the `--confluence-check` flag (see below for the new behaviour).++* New primitive `primStringFromListInjective` internalising the fact that+  `primStringFromList` is an injective function. It is bound in+  `Agda.Builtin.String.Properties`.++* New option `--allow-exec` enables the use of system calls during+  type checking using the `AGDATCMEXECTC` builtin.++* New option `--show-identity-substitutions` shows all arguments of+  metavariables when pretty-printing a term, even if they amount to+  just applying all the variables in the context.++* The option `--rewriting` is now considered infective: if a module has+  `--rewriting` enabled, then all modules importing it must also have+  `--rewriting` enabled.++* New option `--no-double-check` (default), opposite of the existing+  `--double-check`.++* Due to several known soundness issues with sized types (see+  [#1201](https://github.com/agda/agda/issues/1201),+  [#1946](https://github.com/agda/agda/issues/1946),+  [#2820](https://github.com/agda/agda/issues/2820),+  [#3026](https://github.com/agda/agda/issues/3026)), the+  `--sized-types` flag can no longer be used while `--safe` is active.++* New option `--guarded` turns on the Guarded Cubical extension of Agda.++  See [Guarded Cubical](https://agda.readthedocs.io/en/v2.6.2/language/guarded-cubical.html)+  in the documentation for more.++* The flags `--guardedness` and `--sized-types` are no longer enabled+  by default.++Command-line interaction+------------------------++* In the previous release, Agda exited with either status 0 when the+  program type checks successfully, or status 1 when encountering any+  kind of error.  Now Agda exits with status 42 for type errors, 71+  for errors in the commandline arguments, and 154 for impossible+  errors. Exit status 1 may be returned under other circumstances; for+  instance, an incomplete pattern matching, or an error generated by+  the Haskell runtime.  See PR+  [#4540](https://github.com/agda/agda/pull/4540).++Lexical syntax+--------------++* Layout handling has been improved so that block starters can be+  stacked on the same line+  [#1145](https://github.com/agda/agda/issues/1145).++  If several layout blocks are started by layout keywords without line+  break in between (where line breaks inside block comments do not+  count), then those blocks indented *more* than the last block go+  passive, meaning they cannot be further extended by new statements.+  ```agda+    private module M where postulate+              A : Set                 -- module-block goes passive+              B : Set                 -- postulate-block can still be extended+            module N where            -- private-block can still be extended+  ```+  Previously, this was a parse error.++Language+--------++* Inductive records without η-equality no longer support both matching+  on the record constructor and construction of record elements by+  copattern matching.  It has been discovered that the combination of+  both leads to loss of subject reduction, i.e., reduction does not+  preserve typing.  See issue+  [#4560](https://github.com/agda/agda/issues/4560).++  η-equality for a record can be turned off manually with directive+  `no-eta-equality` or command-line option `--no-eta-equality`, but it+  is also automatically turned off for some recursive records.  For+  records without η, matching on the record constructor is now off by+  default and construction by copattern matching is on.  If you want+  the converse, you can add the new record directive `pattern`.++  Example with record pattern:+  ```agda+  record N : Set where+    inductive+    no-eta-equality+    pattern+    field out : Maybe N++  pred : N → Maybe N+  pred record{ out = m } = m+  ```+  Example with record constructor and use of `;` instead of newline:+  ```agda+  record N : Set where+    inductive; no-eta-equality+    pattern; constructor inn+    field out : Maybe N++  pred : N → Maybe N+  pred (inn m) = m+  ```++* `Set` and `Prop` are no longer keywords but are now primitives+  defined in the module `Agda.Primitive`. They can be renamed when+  importing this module, for example:++  ```agda+  open import Agda.Primitive renaming (Set to Type)++  test : Type₁+  test = Type+  ```++  To preserve backwards compatibility, each top-level Agda module now+  starts with an implicit statement:++  ```agda+  open import Agda.Primitive using (Set; Prop)+  ```++  This implicit import can be disabled with the+  `--no-import-sorts` flag.++* Agda now has support for sorts `Setωᵢ` (alternative syntax: `Setωi`)+  for natural numbers `i`, where `Setω₀ = Setω`. These sorts form a+  second hierarchy `Setωᵢ : Setωᵢ₊₁` similar to the standard hierarchy+  of `Setᵢ`, but do not support universe polymorphism. It should not+  be necessary to refer to these sorts during normal usage of Agda,+  but they might be useful for defining reflection-based macros (see+  [#2119](https://github.com/agda/agda/issues/2119) and+  [#4585](https://github.com/agda/agda/issues/4585)).++* Changed the internal representation of literal strings: instead of using a+  linked list of characters (`String`), we are now using `Data.Text`. This+  should be a transparent change from the user's point of view: the backend+  was already packing these strings as text.++  Used this opportunity to introduce a `primStringUncons` primitive in+  `Agda.Builtin.String` (and to correspondingly add the+  `Agda.Builtin.Maybe` it needs).++* The option `--confluence-check` for rewrite rules has been given a+  new implementation that checks global confluence instead of local+  confluence. Concretely, it does so by enforcing two properties:++  1. For any two left-hand sides of the rewrite rules that overlap+     (either at the root position or at a subterm), the most general+     unifier of the two left-hand sides is again a left-hand side of a+     rewrite rule. For example, if there are two rules `suc m + n =+     suc (m + n)` and `m + suc n = suc (m + n)`, then there should+     also be a rule `suc m + suc n = suc (suc (m + n))`.++  2. Each rewrite rule should satisfy the *triangle property*: For any+     rewrite rule `u = w` and any single-step parallel unfolding `u =>+     v`, we should have another single-step parallel unfolding `v =>+     w`.++  The previous behaviour of the confluence checker that only ensures+  local confluence can be restored by using the+  `--local-confluence-check` flag.++* Binary integer literals with prefix `0b` (for instance,+  `0b11001001`) are now supported.++* Overloaded literals now require the conversion function (`fromNat`,+  `fromNeg`, or `fromString`) to be in scope *unqualified* to take+  effect.++  Previously, it was enough for the function to be in scope at all,+  which meant you couldn't import the corresponding builtin module+  without having overloaded literals turned on.++* Added `interleaved mutual` blocks where users can forward-declare+  function, record, and data types and interleave their+  definitions. These blocks are elaborated to more traditional mutual+  blocks by:++    - leaving the signatures where they are+    - grouping the clauses for a function together with the first of them+    - grouping the constructors for a datatype together with the first of them++  Example: two interleaved function definitions++  ```agda++  interleaved mutual++    -- Declarations:+    even : Nat → Bool+    odd  : Nat → Bool++    -- zero is even, not odd+    even zero = true+    odd  zero = false++    -- suc case: switch evenness on the predecessor+    even (suc n) = odd n+    odd  (suc n) = even n+  ```++  Other example: the definition of universe of types closed under the+  natural numbers and pairing:++  ```agda++  interleaved mutual++    -- Declaration of a product record, a universe of codes, and a decoding function+    record _×_ (A B : Set) : Set+    data U : Set+    El : U → Set++    -- We have a code for the type of natural numbers in our universe+    constructor `Nat : U+    El `Nat = Nat++    -- Btw we know how to pair values in a record+    record _×_ A B where+      constructor _,_+      inductive+      field fst : A; snd : B++    -- And we have a code for pairs in our universe+    constructor _`×_ : (A B : U) → U+    El (A `× B) = El A × El B+  ```++* Erased constructors (see+  [#4638](https://github.com/agda/agda/issues/4638)).++  Constructors can be marked as erased. Example:+  ```agda+    {-# OPTIONS --cubical --safe #-}++    open import Agda.Builtin.Cubical.Path+    open import Agda.Primitive++    private+      variable+        a   : Level+        A B : Set a++    Is-proposition : Set a → Set a+    Is-proposition A = (x y : A) → x ≡ y++    data ∥_∥ (A : Set a) : Set a where+      ∣_∣        : A → ∥ A ∥+      @0 trivial : Is-proposition ∥ A ∥++    rec : @0 Is-proposition B → (A → B) → ∥ A ∥ → B+    rec p f ∣ x ∣           = f x+    rec p f (trivial x y i) = p (rec p f x) (rec p f y) i+  ```+  In the code above the constructor `trivial` is only available at+  compile-time, whereas `∣_∣` is also available at run-time. Erased+  names can be used in bodies of clauses that match on `trivial`, if+  the match is done in a non-erased position, like in the final clause+  of `rec`. (Note that Cubical Agda programs still cannot be+  compiled.)++* Erased pattern-matching lambdas (see+  [#4525](https://github.com/agda/agda/issues/4525)).++  Regular pattern-matching lambdas are treated as non-erased+  function definitions. One can make a pattern-matching lambda erased+  by writing `@0` or `@erased` after the lambda:+  ```agda+  @0 _ : @0 Set → Set+  _ = λ @0 { A → A }++  @0 _ : @0 Set → Set+  _ = λ @erased where+    A → A+  ```++  The reflection machinery currently does not support erased+  pattern-matching lambdas (they are quoted as regular+  pattern-matching lambdas).++* New (?) rule for modalities of generalised variables+  (see [#5058](https://github.com/agda/agda/issues/5058)).++  The new rule is that generalisable variables get the modality that+  they are declared with, whereas other variables always get the+  default modality. (It is unclear what the old rule was, perhaps+  nothing was changed.)++* Private abstract type signatures can no longer see through abstract+  (see [#418](https://github.com/agda/agda/issues/418)).++  This means that abstract definitions no longer evaluate in *any*+  type signatures in the same module. Previously they evaluated in+  type signatures of definitions that were both private and abstract.++  It also means that metavariables in type signatures have to be+  solved locally, and cannot make use of information in the definition+  body, and that constructors of abstract datatypes are not in scope+  in type signatures.++* Type inference is disabled for abstract definitions (see+  [#418](https://github.com/agda/agda/issues/418)).++  This means that abstract definitions (inluding functions defined in+  `where` blocks of abstract definitions) need complete type+  signatures.++* One can now declare syntax with two name parts without any hole in+  between, and syntax without any holes.++  Examples:+  ```agda+  syntax Σ A (λ x → B) = [ x ∶ A ] × B+  syntax []            = [ ]+  ```++* Internalised the *inspect idiom* that allows users to abstract over+  an expression in a ``with`` clause while, at the same time,+  remembering the origin of the abstracted pattern via an equation.++  In the following example, abstracting over and then matching on the+  result of ``p x`` allows the first call to ``filter p (x ∷ xs)`` to+  reduce.++  In case the element ``x`` is kept, the second call to ``filter`` on+  the LHS then performs the same ``p x`` test. Because we have+  retained the proof that ``p x ≡ true`` in ``eq``, we are able to+  rewrite by this equality and get it to reduce too.++  This leads to just enough computation that we can finish the proof+  with an appeal to congruence and the induction hypothesis.++  ```agda+  filter-filter : ∀ p xs → filter p (filter p xs) ≡ filter p xs+  filter-filter p []       = refl+  filter-filter p (x ∷ xs) with p x in eq+  ... | false = filter-filter p xs -- easy+  ... | true -- second filter stuck on `p x`: rewrite by `eq`!+    rewrite eq = cong (x ∷_) (filter-filter p xs)+  ```++* As a consequence of the above extensions to `with`, lambdas and lets+  now need parentheses when appearing in a `with`. For instance,++  ```agda+  with-on-fun : Nat → Nat+  with-on-fun n with (λ m → m + n)  -- parentheses required!+  ... | f = f n+  ```++* It is now possible to add hiding and relevance annotations to `with`+  expressions. For example:++  ```agda+  module _ (A B : Set) (recompute : .B → .{{A}} → B) where++    _$_ : .(A → B) → .A → B+    f $ x with .{f} | .(f x) | .{{x}}+    ... | y = recompute y+  ```++Builtins+--------++- Primitive operations for floating-point numbers changed. The equalities now+  follow IEEE 754 equality, after unifying all NaNs. Primitive inequality was+  added:+  ```agda+  primFloatEquality   : Float -> Float -> Bool -- from primFloatNumericEquality+  primFloatLess       : Float -> Float -> Bool -- from primFloatNumericLess+  primFloatInequality : Float -> Float -> Bool -- new+  ```+  The “numeric” relations are now deprecated.++  There are several new predicates on floating-point numbers:+  ```agda+  primFloatIsInfinite     : Float -> Bool -- new+  primFloatIsNaN          : Float -> Bool -- new+  primFloatIsSafeInteger  : Float -> Bool -- new+  ```+  The `primFloatIsSafeInteger` function determines whether the value is a number+  that is a safe integer, i.e., is within the range where the arithmetic+  operations do not lose precision.++  The operations for conversion to integers (`primRound`, `primFloor`,+  and `primCeiling`) were renamed for consistency, and return a value+  of type `Maybe Int`, returning `nothing` for NaN and the infinities:+  ```agda+  primFloatRound   : Float → Maybe Int -- from primRound+  primFloatFloor   : Float → Maybe Int -- from primFloor+  primFloatCeiling : Float → Maybe Int -- from primCeiling+  ```++  There are several new conversions:+  ```agda+  primIntToFloat    : Int -> Float               -- new+  primFloatToRatio  : Float -> (Int × Nat)       -- new+  primRatioToFloat  : Int -> Nat -> Float        -- new+  primFloatDecode   : Float -> Maybe (Int × Int) -- new+  primFloatEncode   : Int -> Int -> Maybe Float  -- new+  ```+  The `primFloatDecode` function decodes a floating-point number f to a mantissa+  and exponent, such that `f = mantissa * 2 ^ exponent`, normalised such that+  the mantissa is the smallest possible number. The `primFloatEncode` function+  encodes a pair of a mantissa and exponent to a floating-point number.++  There are several new operations:+  ```agda+  primFloatPow        : Float -> Float -> Float -- new+  primFloatATan2      : Float -> Float -> Float -- from primATan2+  primFloatSinh       : Float -> Float          -- new+  primFloatCosh       : Float -> Float          -- new+  primFloatTanh       : Float -> Float          -- new+  primFloatASinh      : Float -> Float          -- new+  primFloatACosh      : Float -> Float          -- new+  primFloatATanh      : Float -> Float          -- new+  ```+  Furthermore, the following operations were renamed for consistency:+  ```agda+  primFloatExp        : Float -> Float          -- from primExp+  primFloatSin        : Float -> Float          -- from primSin+  primFloatLog        : Float -> Float          -- from primLog+  primFloatCos        : Float -> Float          -- from primCos+  primFloatTan        : Float -> Float          -- from primTan+  primFloatASin       : Float -> Float          -- from primASin+  primFloatACos       : Float -> Float          -- from primACos+  primFloatATan       : Float -> Float          -- from primATan+  ```++  All of these operations are implemented on the JavaScript backend.++- `primNatToChar` maps surrogate code points to the replacement character+  `'U+FFFD` and surrogate code points are disallowed in character literals++  [Surrogate code points](https://www.unicode.org/glossary/#surrogate_code_point)+  are characters in the range `U+D800` to `U+DFFF` and are reserved for use by+  UTF-16.++  The reason for this change is that strings are represented (at type-checking+  time and in the GHC backend) by Data.Text byte strings, which cannot+  represent surrogate code points and replaces them by `U+FFFD`. By doing the+  same for characters we can have `primStringFromList` be injective (witnessed+  by `Agda.Builtin.String.Properties.primStringFromListInjective`).+++Reflection+----------++- New operation in `TC` monad, similar to `quoteTC` but operating on+  types in `Setω`+  ```agda+  quoteωTC : ∀ {A : Setω} → A → TC Term+  ```+- `typeError` and `debugPrint` no longer inserts spaces around `termErr` and+  `nameErr` parts. They also do a better job of respecting line breaks in+  `strErr` parts.++- The reflection machinery now supports quantities in `Arg` (see+  [#5317](https://github.com/agda/agda/issues/5317)). The `ArgInfo`+  type has changed, and there are new types `Modality` and `Quantity`:+  ```agda+  data Quantity : Set where+    quantity-0 quantity-ω : Quantity++  {-# BUILTIN QUANTITY   Quantity   #-}+  {-# BUILTIN QUANTITY-0 quantity-0 #-}+  {-# BUILTIN QUANTITY-ω quantity-ω #-}++  data Modality : Set where+    modality : (r : Relevance) (q : Quantity) → Modality++  {-# BUILTIN MODALITY             Modality #-}+  {-# BUILTIN MODALITY-CONSTRUCTOR modality #-}++  data ArgInfo : Set where+    arg-info : (v : Visibility) (m : Modality) → ArgInfo+  ```++- The representation of reflected patterns and clauses has+  changed. Each clause now includes a telescope with the names and+  types of the pattern variables.++  ```agda+  data Clause where+    clause        : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) (t : Term) → Clause+    absurd-clause : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) → Clause+  ```++  These telescopes provide additional information on the types of+  pattern variables that was previously hard to reconstruct (see+  [#2151](https://github.com/agda/agda/issues/2151)). When unquoting a+  clause, the types in the clause telescope are currently ignored (but+  this is subject to change in the future).++  Three constructors of the `Pattern` datatype were also changed:++  * pattern variables now refer to a de Bruijn index (relative to the+    clause telescope) rather than a string,+  * absurd patterns take a de Bruijn index and are expected to be bound by the+    clause telescope,+  * dot patterns now include the actual dotted term.++  ```agda+  data Pattern where+    con    : (c : Name) (ps : List (Arg Pattern)) → Pattern+    dot    : (t : Term)    → Pattern   -- previously:   dot : Pattern+    var    : (x : Nat)     → Pattern   -- previously:   var : (x : String) → Pattern+    lit    : (l : Literal) → Pattern+    proj   : (f : Name)    → Pattern+    absurd : (x : Nat)     → Pattern+  ```++  It is likely that this change to the reflected syntax requires you+  to update reflection code written for previous versions of+  Agda. Here are some tips for updating your code:++  * When quoting a clause, you can recover the name of a pattern+    variable by looking up the given index in the clause+    telescope. The contents of dot patterns can safely be ignored+    (unless you have a use for them).++  * When creating a new clause for unquoting, you need to create a+    telescope for the types of the pattern variables. To get back the+    old behaviour of Agda, it is sufficient to set all the types of+    the pattern variables to `unknown`. So you can construct the+    telescope by listing the names of all pattern variables and absurd+    patterns together with their `ArgInfo`. Meanwhile, the pattern+    variables should be numbered in order to update them to the new+    representation. As for the telescope types, the contents of a+    `dot` pattern can safely be set to `unknown`.++- New operation in `TC` monad, `execTC`, which calls an external executable+  ```agda+  execTC : (exe : String) (args : List String) (stdIn : String)+         → TC (Σ Nat (λ _ → Σ String (λ _ → String)))+  ```+  The `execTC` builtin takes three arguments: the basename of the+  executable (e.g., `"echo"`), a list of arguments, and the contents+  of the standard input. It returns a triple, consisting of the exit+  code (as a natural number), the contents of the standard output, and+  the contents of the standard error.++  The builtin is only available when `--allow-exec` is passed. (Note+  that `--allow-exec` is incompatible with ``--safe``.) To make an+  executable available to Agda, add the absolute path on a new line in+  `~/.agda/executables`.++- Two new operations in the `TC` monad, `onlyReduceDefs` and+  `dontReduceDefs`:+  ```agda+  onlyReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A+  dontReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A+  ```+  These functions allow picking a specific set of functions that+  should (resp. should not) be reduced while executing the given `TC`+  computation.++  For example, the following macro unifies the current hole with the+  term `3 - 3`:+  ```agda+  macro₁ : Term -> TC ⊤+  macro₁ goal = do+    u   ← quoteTC ((1 + 2) - 3)+    u'  ← onlyReduceDefs (quote _+_ ∷ []) (normalise u)+    unify u' goal+  ```+- New operation in the `TC` monad, `withReconstructed`:+  ```agda+  withReconstructed : ∀ {a} {A : Set a} → TC A → TC A+  ```++  This function ensures reconstruction of hidden parameters+  after performing the `TC` computation.  For example, consider the+  following type and function:+  ```agda+  record RVec {a} (X : Set a) (n : Nat) : Set a where+    constructor vec+    field sel : Fin n → X++  test-rvec : Nat → RVec Nat 5+  test-rvec x = vec λ _ → x+  ```++  In the reflected syntax the body of the `test-rvec` would be represented+  as `con vec (unknown ∷ unknown ∷ unknown ∷ (lam _ x)`.  The use of+  `withReconstructed` replaces `unknown`s with the actual values:+  ```agda+  macro₂ : Name → Term → TC ⊤+  macro₂ n hole = do+    (function (clause tel ps t ∷ [])) ←+      withReconstructed (getDefinition n)+      where _ → quoteTC "ERROR" >>= unify hole+    quoteTC t >>= unify hole+  ```++- Three new constructors in the `Sort` datatype, `prop : Level →+  Sort`, `propLit : Nat → Sort`, and `inf : Nat → Sort`, representing+  the sorts `Prop ℓ`, `Propᵢ`, and `Setωᵢ`.++- Terms that belong to a type in `Prop` are no longer unquoted to+  `unknown` but to a proper `Term`. (See+  [#3553](https://github.com/agda/agda/issues/3553).)++Library management+------------------++- `.agda-lib` files can now contain an extra field `flags:` with+  default flags for the library. Flags can be any flags that are+  accepted as part of an `{-# OPTIONS ... #-}` pragma. For example,+  file `my-library.agda-lib` with++  ```+  flags: --without-K+  ```++  will apply the `--without-K` flag to all Agda files in the current+  directory and (recursive) subdirectories that do not themselves+  contain an `.agda-lib` file.+++Emacs mode+----------++* New command prefix `C-u C-u C-u` for weak-head normalization. For instance,+  given++  ```agda+  downFrom : Nat → List Nat+  downFrom 0 = []+  downFrom (suc n) = n ∷ downFrom n+  ```++  `C-u C-u C-u C-c C-n downFrom 5` returns `4 ∷ downFrom 4`.++* New keyboard shortcut `C-c C-x C-i` for toggling display of+  irrelevant arguments.++* One can no longer use commands like `M-;` (`comment-dwim`) to+  uncomment block comments. In return one can use `M-;` to comment out+  pragmas. (See [#3329](https://github.com/agda/agda/issues/3329).)++JSON Interaction mode+---------------------++Changes have been made to the structure of error and warning+messages. The changes are summarized below. See+[#5052](https://github.com/agda/agda/issues/5052) for additional+details.++* The format of an error or warning was previously a bare string. Now, errors+  and warnings are represented by an object with a `"message"` key.++  This means that responses _previously_ structured like:++  ```json+  {"…": "…", "error": "Foo bar baz"}+  ```++  will now be structured:++  ```json+  {"…": "…", "error": {"message": "Foo bar baz"}}+  ```++  This applies directly to the `PostPonedCheckFunDef` response kind+  and `Error` info kind of the `DisplayInfo` response kind.++* The format of collections of errors or warnings, which previously were each+  represented by a single newline-joined string, has been updated to represent+  each warning or error individually in a list.++  That means that responses _previously_ structured like:++  ```json+  { "…": "…"+  , "errors": "Postulates overcooked\nAxioms too wiggly"+  , "warnings": "Something wrong\nSomething else\nwrong"+  }+  ```++  will now be structured:++  ```json+  { "…": "…"+  , "errors":+    [ { "message": "Postulates overcooked" }+    , { "message": "Axioms too wiggly" }+    ]+  , "warnings":+    [ { "message": "Something wrong" }+    , { "message": "Something else\nwrong" }+    ]+  }+  ```++  This applies to `CompilationOk`, `AllGoalsWarning`, and `Error` info+  kinds of the `DisplayInfo` response kind.++* The `Error` info kind of the `DisplayInfo` response kind has+  additionally been updated to distinguish warnings and errors.++  An example of the _previous_ format of a `DisplayInfo` response with+  an `Error` info kind was:+  ```json+  {+    "kind": "DisplayInfo",+    "info": {+      "kind": "Error",+      "message": "———— Error —————————————————————————————————————————————————\n/data/code/agda-test/Test.agda:2,1-9\nFailed to find source of module M in any of the following\nlocations:\n  /data/code/agda-test/M.agda\n  /data/code/agda-test/M.lagda\nwhen scope checking the declaration\n  import M\n\n———— Warning(s) ————————————————————————————————————————————\n/data/code/agda-test/Test.agda:3,1-10\nEmpty postulate block."+    }+  }+  ```++  The updated format is:+  ```json+  {+    "kind": "DisplayInfo",+    "info": {+      "kind": "Error",+      "error": {+        "message": "/data/code/agda-test/Test.agda:2,1-9\nFailed to find source of module M in any of the following\nlocations:\n  /data/code/agda-test/M.agda\n  /data/code/agda-test/M.lagda\nwhen scope checking the declaration\n  import M"+      },+      "warnings": [+        {+          "message": "/data/code/agda-test/Test.agda:3,1-10\nEmpty postulate block."+        }+      ]+    }+  }+  ```++Compiler backends -----------------++- With option `--allow-unsolved-metas`, code with holes can be compiled.+  If a hole is reached at runtime, the compiled program crashes.+  See issue [#5103](https://github.com/agda/agda/issues/5103)++- Previously the GHC backend compiled at least one instance of Hinze's+  memoisation technique from ["Memo functions,+  polytypically!"](http://www.cs.ox.ac.uk/ralf.hinze/publications/index.html#P11)+  to reasonably efficient code. That is no longer the case (at least+  for that particular instance, see+  [#5153](https://github.com/agda/agda/issues/5153)).++LaTeX backend+-------------++- The spacing in comments is now preserved when generating LaTex files+  from literate Agda.  See+  [#5320](https://github.com/agda/agda/pull/5320) for more details.++HTML backend+------------++- The named `id` attributes for local modules inside local modules are+  now different (see [#5335](https://github.com/agda/agda/pull/5320)).++  For instance, consider the following Agda file:+  ```agda+  module Top-level where++    module Inner where++      module Inside-inner where+  ```+  Previously one could link to the module `Inside-inner` using a URL+  that ended with `#Inside-inner`. Now one can use+  `#Inner.Inside-inner` instead.++JS backend+----------++- Smaller local variable names in the generated JS code.++  Previously: `x0`, `x1`, `x2`, ...++  Now: `a`, `b`, `c`, ..., `z`, `a0`, `b0`, ..., `z0`, `a1`, `b1`, ...++- Improved indentation of generated JS code.++- More compact rendering of generated JS functions.++  Previously:+  ```js+  exports["N"]["suc"] = function (x0) {+      return function (x1) {+        return x1["suc"](x0);+      };+    };+  ```++  Now:+  ```js+  exports["N"]["suc"] = a => b => b["suc"](a);+  ```++- Irrelevant arguments are now erased in the generated JS code.++  Example Agda code:+  ```agda+  flip : {A B C : Set} -> (B -> A -> C) -> A -> B -> C+  flip f a b = f b a+  ```++  Previously generated JS code:+  ```js+  exports["flip"] = function (x0) {+      return function (x1) {+        return function (x2) {+          return function (x3) {+            return function (x4) {+              return function (x5) {+                return x3(x5)(x4);+              };+            };+          };+        };+      };+    };+  ```++  JS code generated now:+  ```js+  exports["flip"] = a => b => c => a(c)(b);+  ```++- Record fields are not stored separately (the fields are stored only+  in the constructor) in the generated JS code.++  Example Agda code:+  ```agda+  record Sigma (A : Set) (B : A -> Set) : Set where+    field+      fst : A+      snd : B fst+  ```++  Previously generated JS code (look at the `"fst"` and `"snd"` fields in the+  return value of `exports["Sigma"]["record"]`:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = function (x0) {+      return x0["record"]({+        "record": function (x1, x2) {+          return x1;+        }+      });+    };+  exports["Sigma"]["snd"] = function (x0) {+      return x0["record"]({+        "record": function (x1, x2) {+          return x2;+        }+      });+    };+  exports["Sigma"]["record"] = function (x0) {+      return function (x1) {+        return {+          "fst": x0,+          "record": function (x2) {+            return x2["record"](x0, x1);+          },+          "snd": x1+        };+      };+    };+  ```++  JS code generated now:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = a => a["record"]({"record": (b,c) => b});+  exports["Sigma"]["snd"] = a => a["record"]({"record": (b,c) => c});+  exports["Sigma"]["record"] = a => b => ({"record": c => c["record"](a,b)});+  ```++- `--js-optimize` flag has been added to the `agda` compiler.++  With `--js-optimize`, `agda` does not wrap records in JS objects.++  Example Agda code:+  ```agda+  record Sigma (A : Set) (B : A -> Set) : Set where+    field+      fst : A+      snd : B fst+  ```++  JS code generated without the `--js-optimize` flag:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = a => a["record"]({"record": (b,c) => b});+  exports["Sigma"]["snd"] = a => a["record"]({"record": (b,c) => c});+  exports["Sigma"]["record"] = a => b => ({"record": c => c["record"](a,b)});+  ```++  JS code generated with the `--js-optimize` flag:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = a => a((b,c) => b);+  exports["Sigma"]["snd"] = a => a((b,c) => c);+  exports["Sigma"]["record"] = a => b => c => c(a,b);+  ```++  With `--js-optimize`, `agda` uses JS arrays instead of JS objects.+  This is possible because constructor names are not relevant during the evaluation.++  Example Agda code:+  ```agda+  data Bool : Set where+    false : Bool+    true  : Bool++  not : Bool -> Bool+  not false = true+  not true  = false+  ```++  JS code generated without the `--js-optimize` flag:+  ```js+  exports["Bool"] = {};+  exports["Bool"]["false"] = a => a["false"]();+  exports["Bool"]["true"] = a => a["true"]();+  exports["not"] = a => a({+      "false": () => exports["Bool"]["true"],+      "true": () => exports["Bool"]["false"]+    });+  ```++  JS code generated with the `--js-optimize` flag:+  ```js+  exports["Bool"] = {};+  exports["Bool"]["false"] = a => a[0/* false */]();+  exports["Bool"]["true"] = a => a[1/* true */]();+  exports["not"] = a => a([+      /* false */() => exports["Bool"]["true"],+      /* true */() => exports["Bool"]["false"]+    ]);+  ```++  Note that comments are added to generated JS code to help human readers.++  Erased branches are replaced by `null` in the generated array.  If+  more than the half of branches are erased, the array is compressed+  to be a object like `{3: ..., 13: ...}`.++- `--js-minify` flag has been added to the `agda` compiler.++  With `--js-minify`, `agda` discards comments and whitespace in the+  generated JS code.+++Agda as a library (API)+-----------------------++* The `SourceInfo` record has been renamed to `Source`, and the+  `sourceInfo` function to `parseSource`.++Other issues+------------++For 2.6.2, the following issues were also closed (see [bug+tracker](https://github.com/agda/agda/issues)):++  -  [#418](https://github.com/agda/agda/issues/418): Unifier ignores presence of abstract keyword+  -  [#958](https://github.com/agda/agda/issues/958): Module application display forms in parameterised modules+  -  [#1145](https://github.com/agda/agda/issues/1145): Allow multiple layout keywords on the same line+  -  [#2151](https://github.com/agda/agda/issues/2151): Add TC primitive to check left-hand side+  -  [#2461](https://github.com/agda/agda/issues/2461): Support with in the presence of IApply patterns+  -  [#2858](https://github.com/agda/agda/issues/2858): Feature request: Interleaving mutually-defined functions & datatypes+  -  [#3000](https://github.com/agda/agda/issues/3000): Interaction: iterated give encounters internal error+  -  [#3118](https://github.com/agda/agda/issues/3118): Feature request: default flags in .agda-lib file+  -  [#3289](https://github.com/agda/agda/issues/3289): Postfix projections should not have hiding information+  -  [#3360](https://github.com/agda/agda/issues/3360): Make Emacs mode available as a normal package via MELPA+  -  [#3365](https://github.com/agda/agda/issues/3365): Update GitHub linguist syntax highlight file+  -  [#3398](https://github.com/agda/agda/issues/3398): With the option --allow-unsolved-metas, the unsolved metas are not shown, only yellow+  -  [#3422](https://github.com/agda/agda/issues/3422): Show names of instance candidates in error message+  -  [#3486](https://github.com/agda/agda/issues/3486): Elaborate-and-give shouldn't reduce solution+  -  [#3532](https://github.com/agda/agda/issues/3532): Refine does not work for functions with 10 arguments or more+  -  [#3538](https://github.com/agda/agda/issues/3538): Regression: Rewrite rule involving constructors rejected in parametrized module+  -  [#3588](https://github.com/agda/agda/issues/3588): Refine suggests overloaded constructor which is not in scope+  -  [#3627](https://github.com/agda/agda/issues/3627): Where-blocks of clauses with irrelevant projections can use irrelevant variables+  -  [#3644](https://github.com/agda/agda/issues/3644): Error message without position+  -  [#3672](https://github.com/agda/agda/issues/3672): Better error messages for generalize easter eggs+  -  [#3684](https://github.com/agda/agda/issues/3684): Make error about non-existent record field a warning?+  -  [#3734](https://github.com/agda/agda/issues/3734): WARNING_ON_USAGE is not raised for constructors+  -  [#3744](https://github.com/agda/agda/issues/3744): Internal error related to abstract+  -  [#3870](https://github.com/agda/agda/issues/3870): Internal error during instance search+  -  [#3926](https://github.com/agda/agda/issues/3926): Document the effect of `mutual` to the order of type checking+  -  [#3933](https://github.com/agda/agda/issues/3933): `import` can remove definitions from scope+  -  [#3961](https://github.com/agda/agda/issues/3961): Missing documentation for coverage checking+  -  [#4071](https://github.com/agda/agda/issues/4071): Ill-scoped code in error message+  -  [#4088](https://github.com/agda/agda/issues/4088): Strange scoping rules for irrefutable with, part 2+  -  [#4093](https://github.com/agda/agda/issues/4093): Make it possible to rename Set?+  -  [#4109](https://github.com/agda/agda/issues/4109): cannot declare data types in Setω+  -  [#4131](https://github.com/agda/agda/issues/4131): Record definition doesn't compile without a specific `let` binding+  -  [#4132](https://github.com/agda/agda/issues/4132): The regular expression for floats in the lexer is too liberal+  -  [#4135](https://github.com/agda/agda/issues/4135): Constructor disambiguation picks non-unique solution+  -  [#4157](https://github.com/agda/agda/issues/4157): Agda gets confused by multiple anonymous definitions in a single mutual block+  -  [#4160](https://github.com/agda/agda/issues/4160): Printing implicit lambdas with --show-implicit+  -  [#4161](https://github.com/agda/agda/issues/4161): An alternative solution for hGetContent error on Windows when non-English+  -  [#4166](https://github.com/agda/agda/issues/4166): Instances that are not in scope are candidates for instance resolution+  -  [#4208](https://github.com/agda/agda/issues/4208): Field named `_` in `genTel` record+  -  [#4252](https://github.com/agda/agda/issues/4252): Interaction ids get conflated after iterated give+  -  [#4265](https://github.com/agda/agda/issues/4265): Unsolved constraints when --no-syntactic-equality is used+  -  [#4280](https://github.com/agda/agda/issues/4280): Test case for #4169 fails in JS backend+  -  [#4291](https://github.com/agda/agda/issues/4291): Incorrect names can be generated for generalised variables+  -  [#4341](https://github.com/agda/agda/issues/4341): The documentation of inContext seems wrong.+  -  [#4350](https://github.com/agda/agda/issues/4350): Scoping bug with let open in telescope+  -  [#4365](https://github.com/agda/agda/issues/4365): Module fails to type check after parametrising it by postulates+  -  [#4400](https://github.com/agda/agda/issues/4400): TERMINATING pragma in where clause+  -  [#4425](https://github.com/agda/agda/issues/4425): [doc] What are .agdai files?+  -  [#4456](https://github.com/agda/agda/issues/4456): No error highlighting for error warnings?+  -  [#4458](https://github.com/agda/agda/issues/4458): The command agda2-measure-load-time is broken+  -  [#4481](https://github.com/agda/agda/issues/4481): Named implicit arguments do not behave the same in anonymous lambdas & definitions+  -  [#4482](https://github.com/agda/agda/issues/4482): "Unexpected implicit argument" should pinpoint exactly where the error starts+  -  [#4486](https://github.com/agda/agda/issues/4486): "did you mean" hint also for failing imports+  -  [#4491](https://github.com/agda/agda/issues/4491): Add a primitive for Data.Text's uncons+  -  [#4516](https://github.com/agda/agda/issues/4516): Internal error if files cannot be written to the directory for temporary files+  -  [#4518](https://github.com/agda/agda/issues/4518): Confusing error message if missing import+  -  [#4520](https://github.com/agda/agda/issues/4520): Better error for ambiguous BUILTIN [FROMNAT no longer working]+  -  [#4521](https://github.com/agda/agda/issues/4521): Massive increase in memory required to install Agda 2.6.1+  -  [#4526](https://github.com/agda/agda/issues/4526): Agda 2.6.1 bad performance: findProjectConfig slow in big directories+  -  [#4528](https://github.com/agda/agda/issues/4528): Internal error due to new forcing translation+  -  [#4530](https://github.com/agda/agda/issues/4530): Less normalization of goal types for instance search+  -  [#4534](https://github.com/agda/agda/issues/4534): [reflection] quote is not a defined name+  -  [#4536](https://github.com/agda/agda/issues/4536): co-pattern matching on empty record type removes body+  -  [#4538](https://github.com/agda/agda/issues/4538): changing the predefined precedence of an operator+  -  [#4543](https://github.com/agda/agda/issues/4543): Access violation on Windows on GHC 8.8.3, 8.8.4, 8.10.1 and 8.10.2+  -  [#4550](https://github.com/agda/agda/issues/4550): Documentation build: malformed code-block+  -  [#4556](https://github.com/agda/agda/issues/4556): [documentation] update hello world+  -  [#4557](https://github.com/agda/agda/issues/4557): activate github's discussions beta+  -  [#4560](https://github.com/agda/agda/issues/4560): Loss of canonicity with no-eta record and copatterns.+  -  [#4572](https://github.com/agda/agda/issues/4572): add PiSort and UnivSort to the documentation+  -  [#4576](https://github.com/agda/agda/issues/4576): quoteTC for Setω+  -  [#4580](https://github.com/agda/agda/issues/4580): No highlighting for pragmas FROMNAT, FROMNEG, FROMSTRING+  -  [#4583](https://github.com/agda/agda/issues/4583): QuickLaTeX backend does not highlight coinductive constructors as such+  -  [#4586](https://github.com/agda/agda/issues/4586): Better error message  for "Not a valid let declaration"+  -  [#4593](https://github.com/agda/agda/issues/4593): The blocking machinery seems to be broken+  -  [#4595](https://github.com/agda/agda/issues/4595): Should Setω be a type?+  -  [#4596](https://github.com/agda/agda/issues/4596): Improve pattern matching on records in telescopes+  -  [#4606](https://github.com/agda/agda/issues/4606): The combination of Cubical Agda with inductive families is logically inconsistent+  -  [#4610](https://github.com/agda/agda/issues/4610): Support Emacs 27.1+  -  [#4615](https://github.com/agda/agda/issues/4615): Enable --no-sort-comparison by default?+  -  [#4621](https://github.com/agda/agda/issues/4621): Make --rewriting infective+  -  [#4623](https://github.com/agda/agda/issues/4623): Empty where blocks should get dead code warnings+  -  [#4631](https://github.com/agda/agda/issues/4631): Non-linear patterns handled in a buggy way+  -  [#4637](https://github.com/agda/agda/issues/4637): recCon-NOT-PRINTED in termination error in connection to with+  -  [#4638](https://github.com/agda/agda/issues/4638): Erased constructors+  -  [#4649](https://github.com/agda/agda/issues/4649): Repair Agda's REPL (agda -I) to work with --safe flag+  -  [#4656](https://github.com/agda/agda/issues/4656): Function name not wrapped in `\AgdaFunction` in generated LaTeX+  -  [#4662](https://github.com/agda/agda/issues/4662): Current module contents+  -  [#4665](https://github.com/agda/agda/issues/4665): Documentation: add install instructions for stack+  -  [#4671](https://github.com/agda/agda/issues/4671): Weird error message on case-insensitive file systems+  -  [#4679](https://github.com/agda/agda/issues/4679): Cubical: giving seems to skip the boundary condition check for extended lambdas+  -  [#4681](https://github.com/agda/agda/issues/4681): Get rid of auto-inlining?+  -  [#4684](https://github.com/agda/agda/issues/4684): Type error due to --no-syntactic-equality+  -  [#4687](https://github.com/agda/agda/issues/4687): Instance search fails with two equal candidates+  -  [#4704](https://github.com/agda/agda/issues/4704): Case-split generates invalid code+  -  [#4707](https://github.com/agda/agda/issues/4707): Just warn when `using` directive has repetitions+  -  [#4721](https://github.com/agda/agda/issues/4721): de Bruijn index out of scope when using rewriting+  -  [#4727](https://github.com/agda/agda/issues/4727): Meta-variable solutions contain subterms with the wrong modality+  -  [#4735](https://github.com/agda/agda/issues/4735): primShowQName creates not-in-scope names+  -  [#4737](https://github.com/agda/agda/issues/4737): Turn error `Hiding ... has no effect` into a warning+  -  [#4750](https://github.com/agda/agda/issues/4750): Unification failure in 2.6.1 and the master branch+  -  [#4752](https://github.com/agda/agda/issues/4752): Panic on unbound variable with pattern synonym+  -  [#4768](https://github.com/agda/agda/issues/4768): De Bruijn index @0 in error "Not a finite domain"+  -  [#4769](https://github.com/agda/agda/issues/4769): mergeEqualPs ignores Name and ArgInfo of merged-in patterns+  -  [#4772](https://github.com/agda/agda/issues/4772): C-u C-u C-c C-? should show all goals normalized (Cmd_metas)+  -  [#4773](https://github.com/agda/agda/issues/4773): Missing does-not-export warning for `open` directive for parametrised module+  -  [#4775](https://github.com/agda/agda/issues/4775): Internal error when trying to use incorrect lambda syntax to pattern match+  -  [#4784](https://github.com/agda/agda/issues/4784): Make erasure compatible with univalence+  -  [#4795](https://github.com/agda/agda/issues/4795): Build "agda-tests" fails using dynamic linking+  -  [#4815](https://github.com/agda/agda/issues/4815): Current master fails compilation: binding for 'error' shadows the existing binding+  -  [#4828](https://github.com/agda/agda/issues/4828): Symlinks are incorrectly followed during compilation+  -  [#4833](https://github.com/agda/agda/issues/4833): Internal error: cannot type-check file+  -  [#4851](https://github.com/agda/agda/issues/4851): BUILTIN SIGMA and --type-in-type+  -  [#4852](https://github.com/agda/agda/issues/4852): First load the file+  -  [#4857](https://github.com/agda/agda/issues/4857): Instance argument is printed as explicit argument+  -  [#4869](https://github.com/agda/agda/issues/4869): Internal error at src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs:147+  -  [#4880](https://github.com/agda/agda/issues/4880): Non-dependent, irrelevant, nameless arguments aren't accepted in arrows+  -  [#4882](https://github.com/agda/agda/issues/4882): Missing `reduce` in `literalStrategy`+  -  [#4888](https://github.com/agda/agda/issues/4888): "Illegal declaration(s) before top-level module" in Agda 2.6.1+  -  [#4909](https://github.com/agda/agda/issues/4909): Rewrite rule not accepted with --no-fast-reduce+  -  [#4924](https://github.com/agda/agda/issues/4924): Instance resolution loops infinitely even when an instance is available+  -  [#4925](https://github.com/agda/agda/issues/4925): Too aggressive literal overloading+  -  [#4928](https://github.com/agda/agda/issues/4928): Internal error checking cubical library+  -  [#4929](https://github.com/agda/agda/issues/4929): Regression in 2.6.1 connected to forcing translation (internal error)+  -  [#4944](https://github.com/agda/agda/issues/4944): Generalize: stuck on constraint ↑ i =< ↑ (↑ i) : Size+  -  [#4946](https://github.com/agda/agda/issues/4946): Size polarity brittle with generalization+  -  [#4949](https://github.com/agda/agda/issues/4949): Cubical: internal error in eta-expansion under constraints+  -  [#4950](https://github.com/agda/agda/issues/4950): Range too large in complaint about missing definitions+  -  [#4951](https://github.com/agda/agda/issues/4951): Data types in Setω are treated as non-fibrant+  -  [#4952](https://github.com/agda/agda/issues/4952): Incorrect HTML generated for renaming clause+  -  [#4962](https://github.com/agda/agda/issues/4962): JS backend: bugs involving "null"+  -  [#4967](https://github.com/agda/agda/issues/4967): Crazy bug when defining Ord instances for Int+  -  [#4970](https://github.com/agda/agda/issues/4970): `variable` use adds explicit argument+  -  [#4975](https://github.com/agda/agda/issues/4975): "no such meta variable" when calling `C-u C-c C-;`+  -  [#4982](https://github.com/agda/agda/issues/4982): Internal error related to Cubical Agda+  -  [#4986](https://github.com/agda/agda/issues/4986): Pattern matching allows you to turn `(x y : A) -> A` into `(@0 x y : A) -> A`+  -  [#4995](https://github.com/agda/agda/issues/4995): No Cycle should not look under lambdas.+  -  [#4998](https://github.com/agda/agda/issues/4998): Make case in clause with instance projection does not work+  -  [#4999](https://github.com/agda/agda/issues/4999): `primStringFromList` is not injective because of surrogate code points+  -  [#5002](https://github.com/agda/agda/issues/5002): Bad JavaScript generated+  -  [#5005](https://github.com/agda/agda/issues/5005): Add flag to print AGDA_DIR and exit+  -  [#5029](https://github.com/agda/agda/issues/5029): One can override --safe+  -  [#5033](https://github.com/agda/agda/issues/5033): Internal error related to @tick+  -  [#5048](https://github.com/agda/agda/issues/5048): Disturbing names in normalised reflected type+  -  [#5064](https://github.com/agda/agda/issues/5064): Give more information in error "Pattern matching on no-eta record types is by default not allowed"+  -  [#5065](https://github.com/agda/agda/issues/5065): The termination checker is too liberal+  -  [#5079](https://github.com/agda/agda/issues/5079): Deep pattern-matching is sometimes allowed for erased arguments+  -  [#5093](https://github.com/agda/agda/issues/5093): Weird instance propagation between parameterised modules+  -  [#5112](https://github.com/agda/agda/issues/5112): `make install-fix-whitespace` shouldn't use the `stack-X.Y.Z.yaml` files used for Agda+  -  [#5128](https://github.com/agda/agda/issues/5128): getDefinition sometimes loses patterns+  -  [#5133](https://github.com/agda/agda/issues/5133): Current master fails LaTeX-related tests+  -  [#5140](https://github.com/agda/agda/issues/5140): test/LaTeXAndHTML/succeed contains failing tests+  -  [#5146](https://github.com/agda/agda/issues/5146): v2.6.1.2 does not contain MAlonzo/RTE/Float.hs+  -  [#5161](https://github.com/agda/agda/issues/5161): No error location for error in imported module when .agdai file exists+  -  [#5167](https://github.com/agda/agda/issues/5167): Fix broken compatibility with agda-bench+  -  [#5168](https://github.com/agda/agda/issues/5168): User manual: Missing instructions for installing Agda from Hackage using stack+  -  [#5176](https://github.com/agda/agda/issues/5176): `mutual` is deprecated in doc+  -  [#5204](https://github.com/agda/agda/issues/5204): Investigate highlighting failures+  -  [#5205](https://github.com/agda/agda/issues/5205): acmart examples in (user-manual) fail to build with latest TeXLive+  -  [#5207](https://github.com/agda/agda/issues/5207): Agda generated code does not type-check with GHC 9.0+  -  [#5210](https://github.com/agda/agda/issues/5210): Internal error+  -  [#5230](https://github.com/agda/agda/issues/5230): When `stack.yaml` exists, `make` calls `stack`, even on `make debug`+  -  [#5231](https://github.com/agda/agda/issues/5231): Problems compiling hello-world.agda+  -  [#5237](https://github.com/agda/agda/issues/5237): `__IMPOSSIBLE__` from Agda.TypeChecking.Substitute+  -  [#5238](https://github.com/agda/agda/issues/5238): Rewrites are conjuring elements out of thin air+  -  [#5245](https://github.com/agda/agda/issues/5245): An infinite loop?+  -  [#5250](https://github.com/agda/agda/issues/5250): Change of warning options ignored+  -  [#5251](https://github.com/agda/agda/issues/5251): @0 annotation on lambda ignored+  -  [#5252](https://github.com/agda/agda/issues/5252): Internal error when case splitting pattern-lambda with higher rank type+  -  [#5286](https://github.com/agda/agda/issues/5286): Wrong error location with do notation and parse error in lhs+  -  [#5288](https://github.com/agda/agda/issues/5288): Very weird behaviour with compiled Data.Nat.Show.readMaybe+  -  [#5313](https://github.com/agda/agda/issues/5313): Documentation for internal level properties+  -  [#5314](https://github.com/agda/agda/issues/5314): Warn about abstract definitions without type signatures+  -  [#5317](https://github.com/agda/agda/issues/5317): The reflection machinery should support quantities+  -  [#5326](https://github.com/agda/agda/issues/5326): The highlighting code should be optimised+  -  [#5334](https://github.com/agda/agda/issues/5334): Meta-variable in constructor type busts interleaved mutual+  -  [#5335](https://github.com/agda/agda/issues/5335): Incorrect id attributes for local modules inside local modules+  -  [#5336](https://github.com/agda/agda/issues/5336): `data Foo constructor {cs : ts}` notation in `interleaved mutual`+  -  [#5339](https://github.com/agda/agda/issues/5339): `constructor` blocks do not tolerate overloading in same block+  -  [#5341](https://github.com/agda/agda/issues/5341): Do not make context variables non-erased+  -  [#5356](https://github.com/agda/agda/issues/5356): `interleaved mutual`: `data _ where` instead of `constructor`+  -  [#5358](https://github.com/agda/agda/issues/5358): tactic annotation on record field of function type drops domain in copattern definition+  -  [#5367](https://github.com/agda/agda/issues/5367): Parser regression involving `with` and `let`+  -  [#5370](https://github.com/agda/agda/issues/5370): Inconsistency in agda --help+  -  [#5375](https://github.com/agda/agda/issues/5375): Efficient conversion between interaction points and meta-variables+  -  [#5410](https://github.com/agda/agda/issues/5410): Module applications in where clauses of erased definitions yield non-erased code+  -  [#5419](https://github.com/agda/agda/issues/5419): Missing licences?+  -  [#5424](https://github.com/agda/agda/issues/5424): Internal error in v2.6.2 release candidate 1+  -  [#5434](https://github.com/agda/agda/issues/5434): The user manual's explanation of how erasure is checked for constructors does not match the implementation

LICENSE view

@@ -68,3 +68,57 @@ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++------------------------------------------------------------------------++The file src/data/JS/highlight-hover.js (and the following licence+text?) seems to use the following licence:++Copyright 2002-2010, Simon Marlow.  All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++------------------------------------------------------------------------++The file src/data/JS/biginteger.js (and the following licence text?)+seems to use the following licence:++Copyright (c) 2009 Matthew Crumley++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.

README.md view

@@ -4,9 +4,10 @@ [![Hackage version](https://img.shields.io/hackage/v/Agda.svg?label=Hackage)](http://hackage.haskell.org/package/Agda) [![Stackage version](https://www.stackage.org/package/Agda/badge/lts?label=Stackage)](https://www.stackage.org/package/Agda) [![Travis Status](https://travis-ci.org/agda/agda.svg?branch=master)](https://travis-ci.org/agda/agda)+[![Test](https://github.com/agda/agda/workflows/Build,%20Test,%20and%20Benchmark/badge.svg?branch=master)](https://github.com/agda/agda/actions?query=workflow%3A%22Build%2C+Test%2C+and+Benchmark%22) [![Stack Build Status via GH Actions](https://github.com/agda/agda/workflows/stack%20build/badge.svg)](https://github.com/agda/agda/actions?query=workflow%3A%22stack+build%22)-[![Appveyor Status](https://ci.appveyor.com/api/projects/status/x6liln2dol0bg4qw/branch/master?svg=true)](https://ci.appveyor.com/project/gallais/agda)-[![Documentation Status](https://readthedocs.org/projects/agda/badge/?version=latest)](http://agda.readthedocs.io/en/latest/?badge=latest) [![Join the chat at https://gitter.im/agda/agda](https://badges.gitter.im/agda/agda.svg)](https://gitter.im/agda/agda?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)+[![Documentation Status](https://readthedocs.org/projects/agda/badge/?version=latest)](http://agda.readthedocs.io/en/latest/?badge=latest)+[![Agda Zulip](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://agda.zulipchat.com)  ![The official Agda logo](doc/user-manual/agda.svg) @@ -25,10 +26,9 @@ Getting Started ---------------- -* [Prerequisites](http://agda.readthedocs.io/en/latest/getting-started/prerequisites.html)-* [Installation](http://agda.readthedocs.io/en/latest/getting-started/installation.html)+* [Installation](https://agda.readthedocs.io/en/latest/getting-started/installation.html) * [Quick guide to editing, type checking and compiling Agda-  code](http://agda.readthedocs.io/en/latest/getting-started/quick-guide.html)+  code](https://agda.readthedocs.io/en/latest/getting-started/a-taste-of-agda.html)  Contributing to Agda --------------------

Setup.hs view

@@ -42,10 +42,11 @@ copyHook' pd lbi hooks flags = do   -- Copy library and executable etc.   copyHook simpleUserHooks pd lbi hooks flags-  -- Generate .agdai files.-  generateInterfaces pd lbi-  -- Copy again, now including the .agdai files.-  copyHook simpleUserHooks pd' lbi hooks flags+  unless (skipInterfaces lbi) $ do+    -- Generate .agdai files.+    generateInterfaces pd lbi+    -- Copy again, now including the .agdai files.+    copyHook simpleUserHooks pd' lbi hooks flags   where   pd' = pd     { dataFiles = concatMap expandAgdaExt $ dataFiles pd@@ -73,6 +74,11 @@ toIFile :: FilePath -> FilePath toIFile file = replaceExtension file ".agdai" +-- Andreas, 2019-10-21, issue #4151:+-- skip the generation of interface files with program suffix "-quicker"+skipInterfaces :: LocalBuildInfo -> Bool+skipInterfaces lbi = fromPathTemplate (progSuffix lbi) == "-quicker"+ generateInterfaces :: PackageDescription -> LocalBuildInfo -> IO () generateInterfaces pd lbi = do @@ -80,10 +86,6 @@   -- print $ flagAssignment lbi   -- print $ fromPathTemplate $ progSuffix lbi -  -- Andreas, 2019-10-21, issue #4151:-  -- skip the generation of interface files with program suffix "-quicker"-  unless (fromPathTemplate (progSuffix lbi) == "-quicker") $ do-   -- then...   let bdir = buildDir lbi       agda = bdir </> "agda" </> "agda" <.> agdaExeExtension@@ -106,6 +108,7 @@      putStrLn $ "... " ++ fullpath     ok <- rawSystem' ddir agda [ "--no-libraries", "--local-interfaces"+                               , "--ignore-all-interfaces"                                , "-Werror"                                , fullpath, "-v0"                                ]

+ doc/release-notes/2.6.1.3.md view

@@ -0,0 +1,4 @@+Release notes for Agda version 2.6.1.3+======================================++* Added support for GHC 8.10.3.

doc/release-notes/2.6.1.md view

@@ -4,11 +4,14 @@ General ------- -* Agda now has an official logo: ![The official Agda-  logo](doc/user-manual/agda.svg)-  (https://github.com/agda/agda/blob/master/doc/user-manual/agda.svg). The-  logo was chosen by the Agda community from a list of candidates. The winning design was submitted by Miëtek Bak. The list of candidates and the outcome of the poll can be consulted [here](https://civs.cs.cornell.edu/cgi-bin/results.pl?id=E_ce6fe5e2a518ac98).+* Agda now has an official logo: [![The official Agda+  logo](../../doc/user-manual/agda.svg)](https://github.com/agda/agda/blob/master/doc/user-manual/agda.svg). The+  logo was chosen by the Agda community from a list of candidates. The+  winning design was submitted by Miëtek Bak. The list of candidates+  and the outcome of the poll can be consulted+  [here](https://civs.cs.cornell.edu/cgi-bin/results.pl?id=E_ce6fe5e2a518ac98). + Installation and infrastructure ------------------------------- @@ -561,6 +564,7 @@ * Agda will now try to preserve the ellipsis (`...`) during case   splitting when possible. To manually expand the ellipsis, you may   ask Agda to case split on the special identifier `.`.+  [Issue [#2589](https://github.com/agda/agda/issues/2589)]  * Agda will now also show variables named `_` in the context if they   are instance arguments (see

doc/user-manual.pdf view

binary file changed (1265669 → 1228011 bytes)

src/agda-mode/Main.hs view

@@ -127,8 +127,7 @@ alreadyInstalled files = do   exists <- doesFileExist (dotEmacs files)   if not exists then return False else-    withFile (dotEmacs files) ReadMode $ \h ->-      evaluate . (identifier files `isInfixOf`) =<< hGetContents h+    withFile (dotEmacs files) ReadMode $ (evaluate . (identifier files `isInfixOf`)) <=< hGetContents       -- Uses evaluate to ensure that the file is not closed       -- prematurely.

src/data/Agda.css view

@@ -9,6 +9,7 @@ .Agda .PrimitiveType { color: #0000CD } .Agda .Pragma        { color: black   } .Agda .Operator      {}+.Agda .Hole          { background: #B4EEB4 }  /* NameKinds. */ .Agda .Bound                  { color: black   }@@ -37,3 +38,4 @@ /* Standard attributes. */ .Agda a { text-decoration: none } .Agda a[href]:hover { background-color: #B4EEB4 }+.Agda [href].hover-highlight { background-color: #B4EEB4; }

src/data/JS/agda-rts.js view

@@ -1,17 +1,24 @@-// NOTE:-// Some of the primitives here are curried, some are not. All uncurried primitives are prefixed by 'u'.+// Contains *most* of the primitives required by the JavaScript backend.+// (Some, e.g., those using Agda types like Maybe, are defined in their+// respective builtin modules.)+//+// Primitives prefixed by 'u' are uncurried variants, which are sometimes+// emitted by the JavaScript backend. Whenever possible, the curried primitives+// should be implemented in terms of the uncurried ones.+//+// Primitives prefixed by '_' are internal variants, usually for those primitives+// which return Agda types like Maybe. These are never emitted by the compiler,+// but can be used internally to define other prefixes. -var biginteger = require("biginteger")+const biginteger = require("biginteger");  // Integers- exports.primIntegerFromString = function(x) {   return biginteger.BigInteger(x); }; exports.primShowInteger = function(x) {   return x.toString(); };- exports.uprimIntegerPlus = function(x,y) {   return x.add(y); };@@ -37,6 +44,26 @@   return x.compare(y) == -1; }; +// Words+const WORD64_MAX_VALUE = exports.primIntegerFromString("18446744073709552000");++exports.primWord64ToNat = function(x) {+    return x;+};+exports.primWord64FromNat = function(x) {+    return x.remainder(WORD64_MAX_VALUE);+};+exports.uprimWord64Plus = function(x, y) {+    return x.add(y).remainder(WORD64_MAX_VALUE);+};+exports.uprimWord64Minus = function(x, y) {+    return x.add(WORD64_MAX_VALUE).subtract(y).remainder(WORD64_MAX_VALUE);+};+exports.uprimWord64Multiply = function(x, y) {+    return x.multiply(y).remainder(WORD64_MAX_VALUE);+};++// Natural numbers exports.primNatMinus = function(x) {   return function(y) {     var z = x.subtract(y);@@ -48,166 +75,297 @@   }; }; -// Floats--exports.primShowFloat = function(x) {-  // See Issue #2192.-  if (Number.isInteger(x)) {-    if (Object.is(x,-0.0)) {-      return ("-0.0");-    } else {-        var a = x.toString();-        return (a + ".0");+// Floating-point numbers+var _primFloatGreatestCommonFactor = function(x, y) {+    var z;+    x = Math.abs(x);+    y = Math.abs(y);+    while (y) {+        z = x % y;+        x = y;+        y = z;     }-  } else {-    return x.toString();-  }+    return x; };-+exports._primFloatRound = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return Math.round(x);+    }+};+exports._primFloatFloor = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return Math.floor(x);+    }+};+exports._primFloatCeiling = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return Math.ceil(x);+    }+};+exports._primFloatToRatio = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return {numerator: 0.0, denominator: 0.0};+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return {numerator: -1.0, denominator: 0.0};+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return {numerator: 1.0, denominator: 0.0};+    }+    else if (exports.primFloatIsNegativeZero(x)) {+        return {numerator: 0.0, denominator: 1.0};+    }+    else if (x == 0.0) {+        return {numerator: 0.0, denominator: 1.0};+    }+    else {+        var numerator = Math.round(x*1e9);+        var denominator = 1e9;+        var gcf = _primFloatGreatestCommonFactor(numerator, denominator);+        numerator /= gcf;+        denominator /= gcf;+        return {numerator: numerator, denominator: denominator};+    }+};+exports._primFloatDecode = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return null;+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return null;+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        var mantissa = x, exponent = 0;+        while (!Number.isInteger(mantissa)) {+            mantissa *= 2.0;+            exponent -= 1;+        };+        while (mantissa % 2.0 === 0) {+            mantissa /= 2.0;+            exponent += 1;+        }+        return {mantissa: mantissa, exponent: exponent};+    }+};+exports.uprimFloatEquality = function(x, y) {+    return x === y;+}; exports.primFloatEquality = function(x) {-  return function(y) {-    return Object.is(x,y);-  };+    return function(y) {+        return exports.uprimFloatEquality(x, y);+    }; };--exports.primFloatNumericalEquality = function(x) {-  return function(y) {-    return x==y;-  };+exports.primFloatInequality = function(x) {+    return function(y) {+        return x <= y;+    }; };--exports.primFloatNumericalLess = function(x) {-  return function(y) {-    return x < y;-  };+exports.primFloatLess = function(x) {+    return function(y) {+        return x < y;+    }; };+exports.primFloatIsInfinite = function(x) {+    return !Number.isNaN(x) && !Number.isFinite(x);+};+exports.primFloatIsNaN = function(x) {+    return Number.isNaN(x);+};+exports.primFloatIsNegativeZero = function(x) {+    return Object.is(x,-0.0);+};+exports.primFloatIsSafeInteger = function(x) {+    return Number.isSafeInteger(x);+}; -exports.uprimFloatEquality = function(x, y) {-  return Object.is(x,y);++// These WORD64 values were obtained via `castDoubleToWord64` in Haskell:+const WORD64_NAN      = exports.primIntegerFromString("18444492273895866368");+const WORD64_POS_INF  = exports.primIntegerFromString("9218868437227405312");+const WORD64_NEG_INF  = exports.primIntegerFromString("18442240474082181120");+const WORD64_POS_ZERO = exports.primIntegerFromString("0");+const WORD64_NEG_ZERO = exports.primIntegerFromString("9223372036854775808");++exports.primFloatToWord64 = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return WORD64_NAN;+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return WORD64_NEG_INF;+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return WORD64_POS_INF;+    }+    else if (exports.primFloatIsNegativeZero(x)) {+        return WORD64_NEG_ZERO;+    }+    else if (x == 0.0) {+        return WORD64_POS_ZERO;+    }+    else {+        var mantissa, exponent;+        ({mantissa, exponent} = exports._primFloatDecode(x));+        var sign = Math.sign(mantissa);+        console.log(mantissa);+        mantissa *= sign;+        sign = (sign === -1 ? "1" : "0");+        mantissa = (mantissa.toString(2)).padStart(11, "0");+        exponent = (mantissa.toString(2)).padStart(52, "0");+        return exports.primIntegerFromString(parseInt(+            sign + mantissa + exponent, 2).toString());+    } }; -exports.primFloatLess = function(x) {-  return function(y) {-    if(x == Number.NEGATIVE_INFINITY) {-      return y != Number.NEGATIVE_INFINITY;-    } else if(y == Number.NEGATIVE_INFINITY) {-      return false;-    } else if(isNaN(x)) {-      return !isNaN(y);-    } else if(isNaN(y)) {-      return false;+exports.primNatToFloat = function(x) {+    return x.valueOf();+};+exports.primIntToFloat = function(x) {+    return x.valueOf();+};+exports.primRatioToFloat = function(x) {+    return function(y) {+        return x.valueOf() / y.valueOf();+    };+};+exports.uprimFloatEncode = function(x, y) {+    var mantissa = x.valueOf();+    var exponent = y.valueOf();+    if (Number.isSafeInteger(mantissa) && -1024 <= exponent && exponent <= 1024) {+        return mantissa * (2 ** exponent);+    }+    else {+        return null;+    }+};+exports.primShowFloat = function(x) {+    // See Issue #2192.+    if (Number.isInteger(x)) {+        if (exports.primFloatIsNegativeZero(x)) {+            return ("-0.0");+        } else {+            return (x.toString() + ".0");+        }     } else {-      return x < y || Object.is(x, -0.0) && Object.is(y, 0.0);+        return x.toString();     }-  }; };- exports.primFloatPlus = function(x) {-  return function(y) {-    return x+y;-  };+    return function(y) {+        return x + y;+    }; }; exports.primFloatMinus = function(x) {-  return function(y) {-    return x-y;-  };+    return function(y) {+        return x - y;+    }; }; exports.primFloatTimes = function(x) {-  return function(y) {-    return x*y;-  };+    return function(y) {+        return x * y;+    }; };- exports.primFloatNegate = function(x) {-  return -x;+    return -x; };- exports.primFloatDiv = function(x) {   return function(y) {-    return x/y;+    return x / y;   }; };+exports.primFloatPow = function(x) {+    return function(y) {+        return x ** y;+    };+}; exports.primFloatSqrt = function(x) {-  return Math.sqrt(x);+    return Math.sqrt(x); };--exports.primSin = function(x) {-  return Math.sin(x);+exports.primFloatExp = function(x) {+    return Math.exp(x); };--exports.primCos = function(x) {-  return Math.cos(x);+exports.primFloatLog = function(x) {+    return Math.log(x); };--exports.primTan = function(x) {-  return Math.tan(x);+exports.primFloatSin = function(x) {+    return Math.sin(x); };--exports.primASin = function(x) {-  return Math.asin(x);+exports.primFloatCos = function(x) {+    return Math.cos(x); };--exports.primACos = function(x) {-  return Math.acos(x);+exports.primFloatTan = function(x) {+    return Math.tan(x); };--exports.primATan = function(x) {-  return Math.atan(x);+exports.primFloatASin = function(x) {+    return Math.asin(x); };--exports.primATan2 = function(y) {-  return function(x){-    return Math.atan2(y,x);-  }+exports.primFloatACos = function(x) {+    return Math.acos(x); };--exports.primExp = function(x) {-  return Math.exp(x);+exports.primFloatATan = function(x) {+    return Math.atan(x); };+exports.primFloatATan2 = function(x) {+    return function(y){+        return Math.atan2(x, y);+    };+};+exports.primFloatSinh = function(x) {+    return Math.sinh(x);+};+exports.primFloatCosh = function(x) {+    return Math.cosh(x);+};+exports.primFloatTanh = function(x) {+    return Math.tanh(x);+};+exports.primFloatASinh = function(x) {+    return Math.asinh(x);+};+exports.primFloatACosh = function(x) {+    return Math.acosh(x);+};+exports.primFloatATanh = function(x) {+    return Math.atanh(x);+}; -// As Javascript is strict, this should be fine in general. Not sure-// what PSeq (Axiom ...) (...) should do?+// Other stuff exports.primSeq = function(x, y) {   return y; };--exports.primShowQName = function(x) {-  return x["name"];-}; exports.uprimQNameEquality = function(x,y) {-  return x["id"].compare(y["id"]) == 0 && x["moduleId"].compare(y["moduleId"]) == 0;+    return x["id"].compare(y["id"]) == 0 && x["moduleId"].compare(y["moduleId"]) == 0; }; exports.primQNameEquality = function(x) {-  return function(y) {-    return exports.uprimQNameEquality(x, y);-  };+    return function(y) {+        return exports.uprimQNameEquality(x, y);+    }; }; exports.primQNameLess = function(x) {   return function(y) {     switch (x["id"].compare(y["id"])) {       case -1: return true;-      case 1:  return false;-      case 0:-        return x["moduleId"].compare(y["moduleId"]) == -1;-    }+      case  1: return false;+      default: return x["moduleId"].compare(y["moduleId"]) == -1;+    };   }; };+exports.primShowQName = function(x) {+    return x["name"];+}; exports.primQNameFixity = function(x) {-  return x["fixity"];+    return x["fixity"]; }; -// Words-var twoTo64 = exports.primIntegerFromString("18446744073709551616"); -exports.primWord64ToNat = function(x) { return x; };-exports.primWord64FromNat = function(x) { return x.remainder(twoTo64); };--exports.uprimWord64Plus = function(x,y) {-  return x.add(y).remainder(twoTo64);-};-exports.uprimWord64Minus = function(x,y) {-  return x.add(twoTo64).subtract(y).remainder(twoTo64);-};-exports.uprimWord64Multiply = function(x,y) {-  return x.multiply(y).remainder(twoTo64);-};

+ src/data/JS/highlight-hover.js view

@@ -0,0 +1,32 @@+// Copyright 2002-2010, Simon Marlow.  All rights reserved.+// https://github.com/haskell/haddock/blob/ghc-8.8/LICENSE+// Slightly modified by Tesla Ice Zhang++var highlight = function (on) {+  return function () {+    var links = document.getElementsByTagName('a');+    for (var i = 0; i < links.length; i++) {+      var that = links[i];++      if (this.href != that.href) {+        continue;+      }++      if (on) {+        that.classList.add("hover-highlight");+      } else {+        that.classList.remove("hover-highlight");+      }+    }+  }+};++window.onload = function () {+  var links = document.getElementsByTagName('a');+  for (var i = 0; i < links.length; i++) {+    var link = links[i];+    if (!link.hasAttribute("href")) continue;+    link.onmouseover = highlight(true);+    link.onmouseout = highlight(false);+  }+};

src/data/MAlonzo/src/MAlonzo/RTE.hs view

@@ -1,19 +1,11 @@-{-# LANGUAGE CPP       #-} {-# LANGUAGE PolyKinds #-}  module MAlonzo.RTE where  import Unsafe.Coerce import qualified GHC.Exts as GHC (Any)+import Data.Char import qualified Data.Word-import Numeric.IEEE ( IEEE(identicalIEEE, nan) )-#if __GLASGOW_HASKELL__ >= 804-import GHC.Float (castDoubleToWord64)-#else-import System.IO.Unsafe (unsafePerformIO)-import qualified Foreign          as F-import qualified Foreign.Storable as F-#endif  type AgdaAny = GHC.Any @@ -46,6 +38,9 @@ mazUnreachableError :: a mazUnreachableError = error ("Agda: unreachable code reached.") +mazHole :: String -> a+mazHole s = error ("Agda: reached hole: " ++ s)+ addInt :: Integer -> Integer -> Integer addInt = (+) @@ -70,63 +65,12 @@ remInt :: Integer -> Integer -> Integer remInt = rem -eqFloat :: Double -> Double -> Bool-eqFloat x y = identicalIEEE x y || (isNaN x && isNaN y)--eqNumFloat :: Double -> Double -> Bool-eqNumFloat = (==)--ltNumFloat :: Double -> Double -> Bool-ltNumFloat = (<)--negativeZero :: Double-negativeZero = -0.0--positiveInfinity :: Double-positiveInfinity = 1.0 / 0.0--negativeInfinity :: Double-negativeInfinity = -positiveInfinity--positiveNaN :: Double-positiveNaN = 0.0 / 0.0--negativeNaN :: Double-negativeNaN = -positiveNaN---- Adapted from the same function on Agda.Syntax.Literal.-compareFloat :: Double -> Double -> Ordering-compareFloat x y-  | identicalIEEE x y          = EQ-  | isNegInf x                 = LT-  | isNegInf y                 = GT-  | isNaN x && isNaN y         = EQ-  | isNaN x                    = LT-  | isNaN y                    = GT-  | otherwise                  = compare (x, isNegZero y) (y, isNegZero x)-  where-    isNegInf  z = z < 0 && isInfinite z-    isNegZero z = identicalIEEE z negativeZero--ltFloat :: Double -> Double -> Bool-ltFloat x y = case compareFloat x y of-                LT -> True-                _  -> False--#if __GLASGOW_HASKELL__ < 804-castDoubleToWord64 :: Double -> Word64-castDoubleToWord64 float = unsafePerformIO $ F.alloca $ \buf -> do-  F.poke (F.castPtr buf) float-  F.peek buf-#endif--normaliseNaN :: Double -> Double-normaliseNaN x-  | isNaN x   = nan-  | otherwise = x--doubleToWord64 :: Double -> Word64-doubleToWord64 = castDoubleToWord64 . normaliseNaN+-- #4999: Data.Text maps surrogate code points (\xD800 - \xDFFF) to the replacement character+-- \xFFFD, so to keep strings isomorphic to list of characters we do the same for characters.+natToChar :: Integer -> Char+natToChar n | generalCategory c == Surrogate = '\xFFFD'+            | otherwise                      = c+  where c = toEnum $ fromIntegral $ mod n 0x110000  -- Words --

+ src/data/MAlonzo/src/MAlonzo/RTE/Float.hs view

@@ -0,0 +1,274 @@+{-# LANGUAGE CPP #-}++module MAlonzo.RTE.Float where++import Data.Bifunctor   ( bimap, second )+import Data.Function    ( on )+import Data.Maybe       ( fromMaybe )+import Data.Ratio       ( (%), numerator, denominator )+import Data.Word        ( Word64 )++#if __GLASGOW_HASKELL__ >= 804+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+#else+import System.IO.Unsafe (unsafePerformIO)+import qualified Foreign          as F+import qualified Foreign.Storable as F+#endif++#if __GLASGOW_HASKELL__ < 804+castDoubleToWord64 :: Double -> Word64+castDoubleToWord64 float = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) float+  F.peek buf++castWord64ToDouble :: Word64 -> Double+castWord64ToDouble word = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) word+  F.peek buf+#endif++{-# INLINE doubleEq #-}+doubleEq :: Double -> Double -> Bool+doubleEq = (==)++{-# INLINE doubleLe #-}+doubleLe :: Double -> Double -> Bool+doubleLe = (<=)++{-# INLINE doubleLt #-}+doubleLt :: Double -> Double -> Bool+doubleLt = (<)++truncateDouble :: Double -> Double+truncateDouble = castWord64ToDouble . castDoubleToWord64++{-# INLINE intToDouble #-}+intToDouble :: Integral a => a -> Double+intToDouble = truncateDouble . fromIntegral++{-# INLINE doublePlus #-}+doublePlus :: Double -> Double -> Double+doublePlus x y = truncateDouble (x + y)++{-# INLINE doubleMinus #-}+doubleMinus :: Double -> Double -> Double+doubleMinus x y = truncateDouble (x - y)++{-# INLINE doubleTimes #-}+doubleTimes :: Double -> Double -> Double+doubleTimes x y = truncateDouble (x * y)++{-# INLINE doubleNegate #-}+doubleNegate :: Double -> Double+doubleNegate = negate -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleDiv #-}+doubleDiv :: Double -> Double -> Double+doubleDiv = (/) -- NOTE: doesn't cause underflow/overflow++{-# INLINE doublePow #-}+doublePow :: Double -> Double -> Double+doublePow x y = truncateDouble (x ** y)++{-# INLINE doubleSqrt #-}+doubleSqrt :: Double -> Double+doubleSqrt = sqrt -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleExp #-}+doubleExp :: Double -> Double+doubleExp x = truncateDouble (exp x)++{-# INLINE doubleLog #-}+doubleLog :: Double -> Double+doubleLog = log -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSin #-}+doubleSin :: Double -> Double+doubleSin = sin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCos #-}+doubleCos :: Double -> Double+doubleCos = cos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTan #-}+doubleTan :: Double -> Double+doubleTan = tan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASin #-}+doubleASin :: Double -> Double+doubleASin = asin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACos #-}+doubleACos :: Double -> Double+doubleACos = acos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan #-}+doubleATan :: Double -> Double+doubleATan = atan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan2 #-}+doubleATan2 :: Double -> Double -> Double+doubleATan2 = atan2 -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSinh #-}+doubleSinh :: Double -> Double+doubleSinh = sinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCosh #-}+doubleCosh :: Double -> Double+doubleCosh = cosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTanh #-}+doubleTanh :: Double -> Double+doubleTanh = tanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASinh #-}+doubleASinh :: Double -> Double+doubleASinh = asinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACosh #-}+doubleACosh :: Double -> Double+doubleACosh = acosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATanh #-}+doubleATanh :: Double -> Double+doubleATanh = atanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE negativeZero #-}+negativeZero :: Double+negativeZero = -0.0++positiveInfinity :: Double+positiveInfinity = 1.0 / 0.0++negativeInfinity :: Double+negativeInfinity = -positiveInfinity++nan :: Double+nan = 0.0 / 0.0++isPosInf :: Double -> Bool+isPosInf x = x > 0.0 && isInfinite x++isNegInf :: Double -> Bool+isNegInf x = x < 0.0 && isInfinite x++isPosZero :: Double -> Bool+isPosZero x = doubleDenotEq x 0.0++isNegZero :: Double -> Bool+isNegZero x = doubleDenotEq x (-0.0)++doubleRound :: Double -> Maybe Integer+doubleRound = fmap round . asFinite++doubleFloor :: Double -> Maybe Integer+doubleFloor = fmap floor . asFinite++doubleCeiling :: Double -> Maybe Integer+doubleCeiling = fmap ceiling . asFinite++normaliseNaN :: Double -> Double+normaliseNaN x+  | isNaN x   = nan+  | otherwise = x++doubleToWord64 :: Double -> Word64+doubleToWord64 = castDoubleToWord64 . normaliseNaN++-- |Denotational equality for floating point numbers, checks bitwise equality.+--+--  NOTE: Denotational equality distinguishes NaNs, so its results may vary+--        depending on the architecture and compilation flags. Unfortunately,+--        this is a problem with floating-point numbers in general.+--+doubleDenotEq :: Double -> Double -> Bool+doubleDenotEq = (==) `on` doubleToWord64++-- |I guess "denotational orderings" are now a thing? The point is that we need+--  an Ord instance which provides a total ordering, and is consistent with the+--  denotational equality.+--+--  NOTE: The ordering induced via `doubleToWord64` is total, and is consistent+--        with `doubleDenotEq`. However, it is *deeply* unintuitive. For one, it+--        considers all negative numbers to be larger than positive numbers.+--+doubleDenotOrd :: Double -> Double -> Ordering+doubleDenotOrd = compare `on` doubleToWord64++-- |Return Just x if it's a finite number, otherwise return Nothing.+asFinite :: Double -> Maybe Double+asFinite x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just x++-- |Decode a Double to an integer ratio.+doubleToRatio :: Double -> (Integer, Integer)+doubleToRatio x+  | isNaN      x = (0, 0)+  | isInfinite x = (signum (floor x), 0)+  | otherwise    = let r = toRational x in (numerator r, denominator r)++-- |Encode an integer ratio as a double.+ratioToDouble :: Integer -> Integer -> Double+ratioToDouble n d+  | d == 0 = case compare n 0 of+      LT -> negativeInfinity+      EQ -> nan+      GT -> positiveInfinity+  | otherwise = fromRational (n % d)++-- |Decode a Double to its mantissa and its exponent, normalised such that the+--  mantissa is the smallest possible number without loss of accuracy.+doubleDecode :: Double -> Maybe (Integer, Integer)+doubleDecode x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just (uncurry normalise (second toInteger (decodeFloat x)))+  where+    normalise :: Integer -> Integer -> (Integer, Integer)+    normalise mantissa exponent+      | even mantissa = normalise (mantissa `div` 2) (exponent + 1)+      | otherwise = (mantissa, exponent)++-- |Checks whether or not the Double is within a safe range of operation.+isSafeInteger :: Double -> Bool+isSafeInteger x = case properFraction x of+  (n, f) -> f == 0.0 && minMantissa <= n && n <= maxMantissa++doubleRadix :: Integer+doubleRadix = floatRadix (undefined :: Double)++doubleDigits :: Int+doubleDigits = floatDigits (undefined :: Double)++doubleRange :: (Int, Int)+doubleRange = floatRange (undefined :: Double)++-- |The smallest representable mantissa. Simultaneously, the smallest integer which can be+--  represented as a Double without loss of precision.+minMantissa :: Integer+minMantissa = - maxMantissa++-- |The largest representable mantissa. Simultaneously, the largest integer which can be+--  represented as a Double without loss of precision.+maxMantissa :: Integer+maxMantissa = (doubleRadix ^ toInteger doubleDigits) - 1++-- |The largest representable exponent.+minExponent :: Integer+minExponent = toInteger $ (fst doubleRange - doubleDigits) - 1++-- |The smallest representable exponent.+maxExponent :: Integer+maxExponent = toInteger $ snd doubleRange - doubleDigits++-- |Encode a mantissa and an exponent as a Double.+doubleEncode :: Integer -> Integer -> Maybe Double+doubleEncode mantissa exponent+  = if minMantissa <= mantissa && mantissa <= maxMantissa &&+       minExponent <= exponent && exponent <= maxExponent+    then Just (encodeFloat mantissa (fromInteger exponent))+    else Nothing

src/data/agda.sty view

@@ -162,6 +162,7 @@     \definecolor{AgdaUnsolvedConstraint}{HTML}{D3D3D3}     \definecolor{AgdaTerminationProblem}{HTML}{BEBEBE}     \definecolor{AgdaIncompletePattern} {HTML}{D3D3D3}+    \definecolor{AgdaErrorWarning}      {HTML}{BEBEBE}     \definecolor{AgdaError}             {HTML}{696969}      % Misc.@@ -201,6 +202,7 @@     \definecolor{AgdaUnsolvedConstraint}{HTML}{FFD700}     \definecolor{AgdaTerminationProblem}{HTML}{FF0000}     \definecolor{AgdaIncompletePattern} {HTML}{A020F0}+    \definecolor{AgdaErrorWarning}      {HTML}{FF0000}     \definecolor{AgdaError}             {HTML}{F4A460}      % Misc.@@ -239,6 +241,7 @@     \definecolor{AgdaUnsolvedConstraint}{HTML}{FFFF00}     \definecolor{AgdaTerminationProblem}{HTML}{FFA07A}     \definecolor{AgdaIncompletePattern} {HTML}{F5DEB3}+    \definecolor{AgdaErrorWarning}      {HTML}{FFA07A}     \definecolor{AgdaError}             {HTML}{FF0000}      % Misc.@@ -328,6 +331,7 @@ \newcommand{\AgdaTerminationProblem}[1]     {\AgdaFontStyle{\colorbox{AgdaTerminationProblem}{#1}}} \newcommand{\AgdaIncompletePattern} [1]{\colorbox{AgdaIncompletePattern}{#1}}+\newcommand{\AgdaErrorWarning}      [1]{\colorbox{AgdaErrorWarning}{#1}} \newcommand{\AgdaError}             [1]     {\AgdaFontStyle{\textcolor{AgdaError}{\underline{#1}}}} \newcommand{\AgdaCatchallClause}    [1]{#1} % feel free to change this

src/data/emacs-mode/agda-input.el view

@@ -1,5 +1,7 @@+;;; -*- lexical-binding: t; -*- ;;; agda-input.el --- The Agda input method +;; SPDX-License-Identifier: MIT License ;;; Commentary:  ;; A highly customisable input method which can inherit from other@@ -19,7 +21,7 @@ ;;; Code:  (require 'quail)-(require 'cl)+(require 'cl-lib) ;; Quail is quite stateful, so be careful when editing this code.  Note ;; that with-temp-buffer is used below whenever buffer-local state is ;; modified.@@ -50,17 +52,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Functions used to tweak translation pairs -;; lexical-let is used since Elisp lacks lexical scoping.- (defun agda-input-compose (f g)   "\x -> concatMap F (G x)"-  (lexical-let ((f1 f) (g1 g))-    (lambda (x) (agda-input-concat-map f1 (funcall g1 x)))))+    (lambda (x) (agda-input-concat-map f (funcall g x))))  (defun agda-input-or (f g)   "\x -> F x ++ G x"-  (lexical-let ((f1 f) (g1 g))-    (lambda (x) (append (funcall f1 x) (funcall g1 x)))))+    (lambda (x) (append (funcall f x) (funcall g x))))  (defun agda-input-nonempty ()   "Only keep pairs with a non-empty first component."@@ -68,42 +66,36 @@  (defun agda-input-prepend (prefix)   "Prepend PREFIX to all key sequences."-  (lexical-let ((prefix1 prefix))-    (lambda (x) `((,(concat prefix1 (car x)) . ,(cdr x))))))+    (lambda (x) `((,(concat prefix (car x)) . ,(cdr x)))))  (defun agda-input-prefix (prefix)   "Only keep pairs whose key sequence starts with PREFIX."-  (lexical-let ((prefix1 prefix))     (lambda (x)-      (if (equal (substring (car x) 0 (length prefix1)) prefix1)-          (list x)))))+      (if (equal (substring (car x) 0 (length prefix)) prefix)+          (list x))))  (defun agda-input-suffix (suffix)   "Only keep pairs whose key sequence ends with SUFFIX."-  (lexical-let ((suffix1 suffix))     (lambda (x)       (if (equal (substring (car x)-                            (- (length (car x)) (length suffix1)))-                 suffix1)-          (list x)))))+                            (- (length (car x)) (length suffix)))+                 suffix)+          (list x))))  (defun agda-input-drop (ss)   "Drop pairs matching one of the given key sequences. SS should be a list of strings."-  (lexical-let ((ss1 ss))-    (lambda (x) (unless (member (car x) ss1) (list x)))))+    (lambda (x) (unless (member (car x) ss) (list x))))  (defun agda-input-drop-beginning (n)   "Drop N characters from the beginning of each key sequence."-  (lexical-let ((n1 n))-    (lambda (x) `((,(substring (car x) n1) . ,(cdr x))))))+    (lambda (x) `((,(substring (car x) n) . ,(cdr x)))))  (defun agda-input-drop-end (n)   "Drop N characters from the end of each key sequence."-  (lexical-let ((n1 n))     (lambda (x)-      `((,(substring (car x) 0 (- (length (car x)) n1)) .-         ,(cdr x))))))+      `((,(substring (car x) 0 (- (length (car x)) n)) .+         ,(cdr x)))))  (defun agda-input-drop-prefix (prefix)   "Only keep pairs whose key sequence starts with PREFIX.@@ -115,10 +107,9 @@ (defun agda-input-drop-suffix (suffix)   "Only keep pairs whose key sequence ends with SUFFIX. This suffix is dropped."-  (lexical-let ((suffix1 suffix))     (agda-input-compose-     (agda-input-drop-end (length suffix1))-     (agda-input-suffix suffix1))))+     (agda-input-drop-end (length suffix))+     (agda-input-suffix suffix)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization@@ -558,8 +549,8 @@    ;; Parentheses. -  ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢"))-  (")" . ,(agda-input-to-string-list ")]}⁆⁾₎〉⎵⟆⟧⟩⟫⦄〉》」』】〕〗〛︶︸︺︼︾﹀﹂﹄﹚﹜﹞）］｝｣"))+  ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢❪❬❰❲❴⟮⦅⦗⧼⸨❮⦇⦉"))+  (")" . ,(agda-input-to-string-list ")]}⁆⁾₎〉⎵⟆⟧⟩⟫⦄〉》」』】〕〗〛︶︸︺︼︾﹀﹂﹄﹚﹜﹞）］｝｣❫❭❱❳❵⟯⦆⦘⧽⸩❯⦈⦊"))    ("[[" . ("⟦"))   ("]]" . ("⟧"))@@ -576,6 +567,9 @@   ("lbag" . ("⟅"))   ("rbag" . ("⟆")) +  ("<|" . ("⦉"))  ;; Angle bar brackets+  ("|>" . ("⦊"))+   ("(|" . ("⦇"))  ;; Idiom brackets   ("|)" . ("⦈")) @@ -1039,7 +1033,7 @@    ;; Circled, parenthesised etc. numbers and letters. -  ( "(0)" . ,(agda-input-to-string-list " ⓪"))+  ( "(0)" . ,(agda-input-to-string-list " ⓪🄀⓿🄋🄌"))   ( "(1)" . ,(agda-input-to-string-list "⑴①⒈❶➀➊"))   ( "(2)" . ,(agda-input-to-string-list "⑵②⒉❷➁➋"))   ( "(3)" . ,(agda-input-to-string-list "⑶③⒊❸➂➌"))@@ -1050,43 +1044,43 @@   ( "(8)" . ,(agda-input-to-string-list "⑻⑧⒏❽➇➑"))   ( "(9)" . ,(agda-input-to-string-list "⑼⑨⒐❾➈➒"))   ("(10)" . ,(agda-input-to-string-list "⑽⑩⒑❿➉➓"))-  ("(11)" . ,(agda-input-to-string-list "⑾⑪⒒"))-  ("(12)" . ,(agda-input-to-string-list "⑿⑫⒓"))-  ("(13)" . ,(agda-input-to-string-list "⒀⑬⒔"))-  ("(14)" . ,(agda-input-to-string-list "⒁⑭⒕"))-  ("(15)" . ,(agda-input-to-string-list "⒂⑮⒖"))-  ("(16)" . ,(agda-input-to-string-list "⒃⑯⒗"))-  ("(17)" . ,(agda-input-to-string-list "⒄⑰⒘"))-  ("(18)" . ,(agda-input-to-string-list "⒅⑱⒙"))-  ("(19)" . ,(agda-input-to-string-list "⒆⑲⒚"))-  ("(20)" . ,(agda-input-to-string-list "⒇⑳⒛"))+  ("(11)" . ,(agda-input-to-string-list "⑾⑪⒒⓫"))+  ("(12)" . ,(agda-input-to-string-list "⑿⑫⒓⓬"))+  ("(13)" . ,(agda-input-to-string-list "⒀⑬⒔⓭"))+  ("(14)" . ,(agda-input-to-string-list "⒁⑭⒕⓮"))+  ("(15)" . ,(agda-input-to-string-list "⒂⑮⒖⓯"))+  ("(16)" . ,(agda-input-to-string-list "⒃⑯⒗⓰"))+  ("(17)" . ,(agda-input-to-string-list "⒄⑰⒘⓱"))+  ("(18)" . ,(agda-input-to-string-list "⒅⑱⒙⓲"))+  ("(19)" . ,(agda-input-to-string-list "⒆⑲⒚⓳"))+  ("(20)" . ,(agda-input-to-string-list "⒇⑳⒛⓴")) -  ("(a)"  . ,(agda-input-to-string-list "⒜Ⓐⓐ"))-  ("(b)"  . ,(agda-input-to-string-list "⒝Ⓑⓑ"))-  ("(c)"  . ,(agda-input-to-string-list "⒞Ⓒⓒ"))-  ("(d)"  . ,(agda-input-to-string-list "⒟Ⓓⓓ"))-  ("(e)"  . ,(agda-input-to-string-list "⒠Ⓔⓔ"))-  ("(f)"  . ,(agda-input-to-string-list "⒡Ⓕⓕ"))-  ("(g)"  . ,(agda-input-to-string-list "⒢Ⓖⓖ"))-  ("(h)"  . ,(agda-input-to-string-list "⒣Ⓗⓗ"))-  ("(i)"  . ,(agda-input-to-string-list "⒤Ⓘⓘ"))-  ("(j)"  . ,(agda-input-to-string-list "⒥Ⓙⓙ"))-  ("(k)"  . ,(agda-input-to-string-list "⒦Ⓚⓚ"))-  ("(l)"  . ,(agda-input-to-string-list "⒧Ⓛⓛ"))-  ("(m)"  . ,(agda-input-to-string-list "⒨Ⓜⓜ"))-  ("(n)"  . ,(agda-input-to-string-list "⒩Ⓝⓝ"))-  ("(o)"  . ,(agda-input-to-string-list "⒪Ⓞⓞ"))-  ("(p)"  . ,(agda-input-to-string-list "⒫Ⓟⓟ"))-  ("(q)"  . ,(agda-input-to-string-list "⒬Ⓠⓠ"))-  ("(r)"  . ,(agda-input-to-string-list "⒭Ⓡⓡ"))-  ("(s)"  . ,(agda-input-to-string-list "⒮Ⓢⓢ"))-  ("(t)"  . ,(agda-input-to-string-list "⒯Ⓣⓣ"))-  ("(u)"  . ,(agda-input-to-string-list "⒰Ⓤⓤ"))-  ("(v)"  . ,(agda-input-to-string-list "⒱Ⓥⓥ"))-  ("(w)"  . ,(agda-input-to-string-list "⒲Ⓦⓦ"))-  ("(x)"  . ,(agda-input-to-string-list "⒳Ⓧⓧ"))-  ("(y)"  . ,(agda-input-to-string-list "⒴Ⓨⓨ"))-  ("(z)"  . ,(agda-input-to-string-list "⒵Ⓩⓩ"))+  ("(a)"  . ,(agda-input-to-string-list "⒜Ⓐⓐ🅐🄰🅰"))+  ("(b)"  . ,(agda-input-to-string-list "⒝Ⓑⓑ🅑🄱🅱"))+  ("(c)"  . ,(agda-input-to-string-list "⒞Ⓒⓒ🅒🄲🅲"))+  ("(d)"  . ,(agda-input-to-string-list "⒟Ⓓⓓ🅓🄳🅳"))+  ("(e)"  . ,(agda-input-to-string-list "⒠Ⓔⓔ🅔🄴🅴"))+  ("(f)"  . ,(agda-input-to-string-list "⒡Ⓕⓕ🅕🄵🅵"))+  ("(g)"  . ,(agda-input-to-string-list "⒢Ⓖⓖ🅖🄶🅶"))+  ("(h)"  . ,(agda-input-to-string-list "⒣Ⓗⓗ🅗🄷🅷"))+  ("(i)"  . ,(agda-input-to-string-list "⒤Ⓘⓘ🅘🄸🅸"))+  ("(j)"  . ,(agda-input-to-string-list "⒥Ⓙⓙ🅙🄹🅹"))+  ("(k)"  . ,(agda-input-to-string-list "⒦Ⓚⓚ🅚🄺🅺"))+  ("(l)"  . ,(agda-input-to-string-list "⒧Ⓛⓛ🅛🄻🅻"))+  ("(m)"  . ,(agda-input-to-string-list "⒨Ⓜⓜ🅜🄼🅼"))+  ("(n)"  . ,(agda-input-to-string-list "⒩Ⓝⓝ🅝🄽🅽"))+  ("(o)"  . ,(agda-input-to-string-list "⒪Ⓞⓞ🅞🄾🅾"))+  ("(p)"  . ,(agda-input-to-string-list "⒫Ⓟⓟ🅟🄿🅿"))+  ("(q)"  . ,(agda-input-to-string-list "⒬Ⓠⓠ🅠🅀🆀"))+  ("(r)"  . ,(agda-input-to-string-list "⒭Ⓡⓡ🅡🅁🆁"))+  ("(s)"  . ,(agda-input-to-string-list "⒮Ⓢⓢ🅢🅂🆂"))+  ("(t)"  . ,(agda-input-to-string-list "⒯Ⓣⓣ🅣🅃🆃"))+  ("(u)"  . ,(agda-input-to-string-list "⒰Ⓤⓤ🅤🅄🆄"))+  ("(v)"  . ,(agda-input-to-string-list "⒱Ⓥⓥ🅥🅅🆅"))+  ("(w)"  . ,(agda-input-to-string-list "⒲Ⓦⓦ🅦🅆🆆"))+  ("(x)"  . ,(agda-input-to-string-list "⒳Ⓧⓧ🅧🅇🆇"))+  ("(y)"  . ,(agda-input-to-string-list "⒴Ⓨⓨ🅨🅈🆈"))+  ("(z)"  . ,(agda-input-to-string-list "⒵Ⓩⓩ🅩🅉🆉"))    ))   "A list of translations specific to the Agda input method.

src/data/emacs-mode/agda2-abbrevs.el view

@@ -1,4 +1,5 @@ ;; agda2-abbrevs.el --- Default Agda abbrevs+;; SPDX-License-Identifier: MIT License  ;;; Commentary:

src/data/emacs-mode/agda2-highlight.el view

@@ -1,4 +1,5 @@ ;;; agda2-highlight.el --- Syntax highlighting for Agda (version ≥ 2)+;; SPDX-License-Identifier: MIT License  ;;; Commentary: @@ -122,6 +123,9 @@             (agda2-highlight-error-face              :foreground "red"              :underline t)+            (agda2-highlight-error-warning-face+             :background "light coral"+             :underline t)             (agda2-highlight-unsolved-meta-face              :foreground "black"              :background "yellow")@@ -385,6 +389,14 @@   "The face used for errors."   :group 'agda2-highlight-faces) +(defface agda2-highlight-error-warning-face+  '((((background light))+     (:background "light coral" :underline t))+    (((background dark))+     (:background "#802400" :underline t)))+  "The face used for fatal warnings."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-unsolved-meta-face   '((((background light))      (:background "yellow"))@@ -498,6 +510,7 @@     (dotted                 . agda2-highlight-dotted-face)     (operator               . agda2-highlight-operator-face)     (error                  . agda2-highlight-error-face)+    (errorwarning           . agda2-highlight-error-warning-face)     (unsolvedmeta           . agda2-highlight-unsolved-meta-face)     (unsolvedconstraint     . agda2-highlight-unsolved-constraint-face)     (terminationproblem     . agda2-highlight-termination-problem-face)@@ -524,6 +537,7 @@ `deadcode'               Deadcode (like unreachable clauses or RHS). `dotted'                 Dotted patterns. `error'                  Errors.+`errorwarning'           Fatal warnings. `field'                  Record fields. `function'               Functions. `generalizable'          Generalizable variables.

src/data/emacs-mode/agda2-mode-pkg.el view

@@ -1,2 +1,3 @@-(define-package "agda2-mode" "2.6.1.3"-  "interactive development for Agda, a dependently typed functional programming language")+(define-package "agda2-mode" "2.6.2"+  "interactive development for Agda, a dependently typed functional programming language"+  '((emacs "24.3") (annotation "1.0") (eri "1.0")))

src/data/emacs-mode/agda2-mode.el view

@@ -1,8 +1,26 @@ ;;; agda2-mode.el --- Major mode for Agda+;; SPDX-License-Identifier: MIT License  ;;; Commentary: +;; A major mode for editing Agda (the dependently typed programming+;; language / interactive theorem prover). ;;+;; Major features include:+;;+;; - syntax highlighting.+;;+;; - on the fly Agda interpretation.+;;+;; - goal-driven development+;;+;; - interactive case-splitting+;;+;; - proof search+;;+;; - input support (for utf8 characters)+;;+;; see https://agda.readthedocs.io/ for more information  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Dependency@@ -10,11 +28,11 @@  ;;; Code: -(defvar agda2-version "2.6.1.3"+(defvar agda2-version "2.6.2"   "The version of the Agda mode. Note that the same version of the Agda executable must be used.") -(require 'cl)+(require 'cl-lib) (require 'compile) (require 'pp) (require 'time-date)@@ -185,13 +203,12 @@                         (modify-syntax-entry keys "w" tbl)))                     (standard-syntax-table))     ;; Then override the remaining special cases.-    (dolist (cs '((?{ . "(}1n") (?} . "){4n") (?- . "w 123b") (?\n . "> b")+    (dolist (cs '((?- . "w 12") (?\n . ">")                   (?. . ".") (?\; . ".") (?! . ".")))       (modify-syntax-entry (car cs) (cdr cs) tbl))     tbl)   "Syntax table used by the Agda mode: -{}  | Comment characters, matching parentheses. -   | Comment character, word constituent. \n  | Comment ender. .;! | Punctuation.@@ -211,6 +228,7 @@     (agda2-abort                             "\C-c\C-x\C-a"       (global)       "Abort a command")     (agda2-remove-annotations                "\C-c\C-x\C-d"       (global)       "Remove goals and highlighting (\"deactivate\")")     (agda2-display-implicit-arguments        "\C-c\C-x\C-h"       (global)       "Toggle display of hidden arguments")+    (agda2-display-irrelevant-arguments      "\C-c\C-x\C-i"       (global)       "Toggle display of irrelevant arguments")     (agda2-show-constraints                  ,(kbd "C-c C-=")     (global)       "Show constraints")     (agda2-solve-maybe-all                   ,(kbd "C-c C-s")     (local global) "Solve constraints")     (agda2-show-goals                        ,(kbd "C-c C-?")     (global)       "Show goals")@@ -258,7 +276,7 @@       (cons "Agda" (make-sparse-keymap "Agda")))     (define-key map [down-mouse-3]  'agda2-popup-menu-3)     (dolist (d (reverse agda2-command-table))-      (destructuring-bind (f &optional keys kinds desc) d+      (cl-destructuring-bind (f &optional keys kinds desc) d         (if keys (define-key map keys f))         (if (member 'global kinds)             (define-key map@@ -269,7 +287,7 @@ (defvar agda2-goal-map   (let ((map (make-sparse-keymap "Agda goal")))     (dolist (d (reverse agda2-command-table))-      (destructuring-bind (f &optional keys kinds desc) d+      (cl-destructuring-bind (f &optional keys kinds desc) d         (if (member 'local kinds)             (define-key map               (vector (intern desc)) (cons desc f)))))@@ -535,7 +553,7 @@ is non-nil and the Agda process is `busy'."    ; Check that how-busy is well-formed.-  (assert (or (equal how-busy 'busy)+  (cl-assert (or (equal how-busy 'busy)               (equal how-busy 'not-so-busy)))    (when (and agda2-in-progress@@ -753,7 +771,7 @@  If SAVE is 'save, then the buffer is saved just before the command is sent to Agda (if it is sent)."-  (multiple-value-bind (o g) (agda2-goal-at (point))+  (cl-multiple-value-bind (o g) (agda2-goal-at (point))     (unless g (error "For this command, please place the cursor in a goal"))     (let ((txt (buffer-substring-no-properties (+ (overlay-start o) 2)                                                (- (overlay-end   o) 2)))@@ -916,8 +934,8 @@     (re-search-backward "{!")     (while (and (not (equal (preceding-char) ?\;)) (>= bracketCount 0) (> (point) p1))       (backward-char)-      (if (equal (preceding-char) ?}) (incf bracketCount))-      (if (equal (preceding-char) ?{) (decf bracketCount)))+      (if (equal (preceding-char) ?}) (cl-incf bracketCount))+      (if (equal (preceding-char) ?{) (cl-decf bracketCount)))     (let* ((is-lambda-where (= (point) p1))            (p (point)))       (delete-region (point) pmax)@@ -1054,10 +1072,6 @@   (kill-new text)   (agda2-info-action name text append)) -(defun agda2-show-goals()-  "Show all goals." (interactive)-  (agda2-go nil t 'busy t "Cmd_metas"))- (defun agda2-show-constraints()   "Show constraints." (interactive)   (agda2-go nil t 'busy t "Cmd_constraints"))@@ -1142,11 +1156,11 @@ ;; functions which can be used either directly from a goal or at a global ;; level and are modifiable using one of three levels of normalisation. -(defmacro agda2-proto-maybe-normalised (name comment cmd norm0 norm1 norm2 spec)+(defmacro agda2-proto-maybe-normalised (name comment cmd norm0 norm1 norm2 norm3 spec)   "This macro constructs a function NAME which runs CMD. COMMENT is used to build the function's comment. The function NAME takes a prefix argument which tells whether it-should normalise types according to either NORM0, NORM1, or NORM2+should normalise types according to either NORM0, NORM1, NORM2, or NORM3 when running CMD through `agda2-goal-cmd`. SPEC can be either (fromgoal want) or (global prompt). "@@ -1166,9 +1180,13 @@   exactly once right before the command is invoked), then the   result is %s. +* If the prefix argument is `(16)' (for instance if C-u is typed+  exactly twice right before the command is invoked), then the+  result is %s.+ * If any other prefix argument is used (for instance if C-u is-  typed twice right before the command is invoked), then the-  result is %s." comment (nth 1 norm0) (nth 1 norm1) (nth 1 norm2))+  typed thrice right before the command is invoked), then the+  result is %s." comment (nth 1 norm0) (nth 1 norm1) (nth 1 norm2) (nth 1 norm3))         ;; All the commands generated by the macro are interactive.        ;; Those called from a goal, grab the value present there (if any)@@ -1186,14 +1204,16 @@                            ,(car norm0))                           ((equal ,prefix '(4))                            ,(car norm1))-                          (t ,(car norm2)))))+                          ((equal ,prefix '(16))+                           ,(car norm2))+                          (t ,(car norm3)))))        ;; Finally, if the command is called from a goal, we use `agda2-goal-cmd'        ;; Otherwise we resort to `agda2-go'          ,(pcase spec             (`(fromgoal ,want)              `(agda2-goal-cmd (concat ,cmd " " ,eval) nil ,want))             (`(global ,prompt)-             `(agda2-go nil nil 'busy t+             `(agda2-go nil t 'busy t                         (concat ,cmd " "                                 ,eval " "                                 (if ,prompt@@ -1206,6 +1226,7 @@     ("Simplified"   "simplified")     ("Instantiated" "neither explicitly normalised nor simplified")     ("Normalised"   "normalised")+    ("HeadNormal"   "head normalised")     (fromgoal ,want)))  (defmacro agda2-maybe-normalised-asis (name comment cmd want)@@ -1214,6 +1235,7 @@     ("AsIs"       "returned as is")     ("Simplified" "simplified")     ("Normalised" "normalised")+    ("HeadNormal" "head normalised")     (fromgoal ,want)))  (defmacro agda2-maybe-normalised-toplevel (name comment cmd prompt)@@ -1222,6 +1244,7 @@     ("Simplified"   "simplified")     ("Instantiated" "neither explicitly normalised nor simplified")     ("Normalised"   "normalised")+    ("HeadNormal"   "head normalised")     (global ,prompt)))  (defmacro agda2-maybe-normalised-toplevel-asis-noprompt (name comment cmd)@@ -1230,6 +1253,7 @@     ("AsIs"       "returned as is")     ("Simplified" "simplified")     ("Normalised" "normalised")+    ("HeadNormal" "head normalised")     (global nil)))  (agda2-maybe-normalised@@ -1269,7 +1293,7 @@ (defun agda2-why-in-scope-toplevel (name)   "Explain why something is in scope at the top level."   (interactive "MName: ")-  (agda2-go nil nil 'busy t+  (agda2-go nil t 'busy t             "Cmd_why_in_scope_toplevel"             (agda2-string-quote name))) @@ -1321,14 +1345,14 @@   "Shows all the top-level names in the given module. Along with their types."   "Cmd_show_module_contents"-  "Module name")+  "Module name (empty for current module)")  (agda2-maybe-normalised-toplevel   agda2-module-contents-toplevel   "Shows all the top-level names in the given module. Along with their types."   "Cmd_show_module_contents_toplevel"-  "Module name"+  "Module name (empty for top-level module)" )  (agda2-maybe-normalised-toplevel@@ -1368,6 +1392,12 @@ )  (agda2-maybe-normalised-toplevel-asis-noprompt+ agda2-show-goals+ "Show all goals."+ "Cmd_metas"+ )++(agda2-maybe-normalised-toplevel-asis-noprompt  agda2-solveAll  "Solves all goals that are already instantiated internally."  "Cmd_solveAll"@@ -1397,17 +1427,20 @@ (defun agda2-compute-normalised (&optional arg)   "Compute the normal form of the expression in the goal at point. -With a prefix argument distinct from `(4)' the normal form of+With the prefix argument `(4)' \"abstract\" is ignored during the+computation.++With a prefix argument `(16)' the normal form of \"show <expression>\" is computed, and then the resulting string is printed. -With the prefix argument `(4)' \"abstract\" is ignored during the-computation."+With any other prefix the head normal form is computed."   (interactive "P")   (let ((cmd (concat "Cmd_compute"                       (cond ((equal arg nil) " DefaultCompute")                             ((equal arg '(4)) " IgnoreAbstract")-                            (" UseShowInstance")))))+                            ((equal arg '(16)) " UseShowInstance")+                            (" HeadCompute")))))     (agda2-goal-cmd cmd nil "expression to normalise")))  (defun agda2-compute-normalised-toplevel (expr &optional arg)@@ -1425,8 +1458,9 @@   (let ((cmd (concat "Cmd_compute_toplevel"                      (cond ((equal arg nil) " DefaultCompute")                             ((equal arg '(4)) " IgnoreAbstract")-                            (" UseShowInstance")) " ")))-    (agda2-go nil nil 'busy t+                            ((equal arg '(16)) " UseShowInstance")+                            (" HeadCompute")) " ")))+    (agda2-go nil t 'busy t               (concat cmd (agda2-string-quote expr)))))  (defun agda2-compute-normalised-maybe-toplevel ()@@ -1589,14 +1623,14 @@  Removes the goal braces, but does not remove the goal overlay or text properties."-  (multiple-value-bind (p q) (agda2-range-of-goal old-g)+  (cl-multiple-value-bind (p q) (agda2-range-of-goal old-g)     (save-excursion       (cond ((stringp new-txt)              (agda2-replace-goal old-g new-txt))             ((equal new-txt 'paren)              (goto-char (- q 2)) (insert ")")              (goto-char (+ p 2)) (insert "(")))-      (multiple-value-bind (p q) (agda2-range-of-goal old-g)+      (cl-multiple-value-bind (p q) (agda2-range-of-goal old-g)         (delete-region (- q 2) q)         (delete-region p (+ p 2)))         ;; Update highlighting@@ -1696,7 +1730,7 @@ (defun agda2-replace-goal (g newtxt)   "Replace the content of goal G with NEWTXT." (interactive)   (save-excursion-    (multiple-value-bind (p q) (agda2-range-of-goal g)+    (cl-multiple-value-bind (p q) (agda2-range-of-goal g)       (setq p (+ p 2) q (- q 2))       (let ((indent (and (goto-char p) (current-column))))         (delete-region p q) (insert newtxt)@@ -1885,6 +1919,21 @@    (t (agda2-go nil t 'not-so-busy t "ShowImplicitArgs" "False"))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Irrelevant arguments++(defun agda2-display-irrelevant-arguments (&optional arg)+  "Toggle display of irrelevant arguments.+With prefix argument, turn on display of irrelevant arguments if+the argument is a positive number, otherwise turn it off."+  (interactive "P")+  (cond+   ((eq arg nil)+      (agda2-go nil t 'not-so-busy t "ToggleIrrelevantArgs"))+   ((and (numberp arg) (> arg 0))+      (agda2-go nil t 'not-so-busy t "ShowIrrelevantArgs" "True"))+   (t (agda2-go nil t 'not-so-busy t "ShowIrrelevantArgs" "False"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;  (defun agda2-popup-menu-3 (ev)@@ -1900,7 +1949,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Switching to a different version of Agda -(defun get-agda-program-versions ()+(defun agda2-get-agda-program-versions ()   "Get \"version strings\" of executables starting with 'agda-mode' in current path."   (delete-dups@@ -1908,9 +1957,9 @@              ;; strip 'agda-mode' prefix              (replace-regexp-in-string "^agda-mode-?" ""                                        (file-name-nondirectory path)))-           (remove-if-not 'file-executable-p+           (cl-remove-if-not 'file-executable-p              ;; concatenate result-             (reduce 'append+             (cl-reduce 'append                      ;; for each directory in exec-path, get list of                      ;; files whose name starts with 'agda-mode'                      (mapcar (lambda (path)@@ -1929,11 +1978,11 @@ agda-mode-VERSION, and that they are located on the PATH. (If VERSION is empty, then agda and agda-mode are used instead.)"   (interactive-   (list (completing-read "Version: " (get-agda-program-versions))))+   (list (completing-read "Version: " (agda2-get-agda-program-versions))))    (let*       ((agda-buffers-        (mapcan (lambda (buf)+        (cl-mapcan (lambda (buf)                   (with-current-buffer buf                     (when (equal major-mode 'agda2-mode)                       (list buf))))

src/data/emacs-mode/agda2-queue.el view

@@ -1,4 +1,5 @@ ;;; agda2-queue.el --- Simple FIFO character queues.+;; SPDX-License-Identifier: MIT License  (defun agda2-queue-empty ()   "Creates a new empty FIFO character queue.

src/data/emacs-mode/agda2.el view

@@ -1,6 +1,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Agda mode code which should run before the first Agda file is ;; loaded+;; SPDX-License-Identifier: MIT License  (defvar agda2-directory (file-name-directory load-file-name)   "Path to the directory that contains agda2.el(c).")

src/data/emacs-mode/annotation.el view

@@ -1,9 +1,17 @@ ;;; annotation.el --- Functions for annotating text with faces and help bubbles +;; Version: 1.0++;; SPDX-License-Identifier: MIT License+;; URL: https://github.com/agda/agda+;; Version: 1.0++;;; Commentary:+ ;; Note that this library enumerates buffer positions starting from 1, ;; just like Emacs. -(require 'cl)+(require 'cl-lib)  (defvar annotation-bindings nil   "An association list mapping symbols to faces.")@@ -97,14 +105,14 @@  Precondition: START and END must be numbers, and START must be less than END."-  (assert (condition-case nil (< start end) (error nil)))+  (cl-assert (condition-case nil (< start end) (error nil)))   (let ((pos start)         mid)     (while (< pos end)       (setq mid (next-single-property-change pos 'annotation-faces                                              nil end))       (let* ((old-faces (get-text-property pos 'annotation-faces))-             (all-faces (union old-faces faces)))+             (all-faces (cl-union old-faces faces)))         (mapc (lambda (prop) (put-text-property pos mid prop all-faces))               '(annotation-faces face))         (setq pos mid)))))@@ -186,7 +194,7 @@               (setq mid (next-single-property-change pos                            'annotation-annotations nil end))               (let* ((old-props (get-text-property pos 'annotation-annotations))-                     (all-props (union old-props props)))+                     (all-props (cl-union old-props props)))                 (add-text-properties pos mid                    `(annotation-annotated t annotation-annotations ,all-props))                 (setq pos mid)))))))))@@ -238,7 +246,7 @@                     (or (not token-based)                         (member 'annotation-token-based props)))            (remove-text-properties pos (or pos2 (point-max))-              (mapcan (lambda (prop) (list prop nil))+              (cl-mapcan (lambda (prop) (list prop nil))                       (cons 'annotation-annotations props)))))        (setq pos (unless (or (not pos2) (>= pos2 end)) pos2)))))) @@ -274,7 +282,7 @@     (when (listp cmds)       (let ((pos (point-min)))         (dolist (cmd cmds)-          (destructuring-bind+          (cl-destructuring-bind               (start end anns &optional token-based info goto) cmd             (let ((info (if (and (not info) (consp goto))                             goto-help

src/data/emacs-mode/eri.el view

@@ -1,10 +1,16 @@ ;;; eri.el --- Enhanced relative indentation (eri) +;; SPDX-License-Identifier: MIT License+;; URL: https://github.com/agda/agda+;; Version: 1.0+ ;;; Commentary: +;; Cycle between indentation points with enhanced relative indentation.+ ;;; Code: -(require 'cl)+(require 'cl-lib)  (defun eri-current-line-length nil   "Calculate length of current line."@@ -28,7 +34,7 @@   "Return a pair of lists (XS1 . XS2). If XS is sorted, then XS = (append XS1 XS2), and all elements in XS1 are <= X, whereas all elements in XS2 are > X."-  (let* ((pos (or (position-if (lambda (y) (> y x)) xs) (length xs)))+  (let* ((pos (or (cl-position-if (lambda (y) (> y x)) xs) (length xs)))          (xs1 (eri-take pos xs))          (xs2 (nthcdr pos xs)))     (cons xs1 xs2)))

src/data/lib/prim/Agda/Builtin/Bool.agda view

@@ -10,8 +10,6 @@ {-# BUILTIN FALSE false #-} {-# BUILTIN TRUE  true  #-} -{-# COMPILE UHC Bool = data __BOOL__ (__FALSE__ | __TRUE__) #-}- {-# COMPILE JS Bool  = function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-} {-# COMPILE JS false = false #-} {-# COMPILE JS true  = true  #-}

src/data/lib/prim/Agda/Builtin/Coinduction.agda view

@@ -1,5 +1,5 @@ {-# OPTIONS --without-K --safe --universe-polymorphism --no-sized-types-            --no-guardedness --no-subtyping #-}+            --guardedness --no-subtyping #-}  module Agda.Builtin.Coinduction where

src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda view

@@ -64,8 +64,6 @@       → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}       → primGlue A T e → A -    -- Needed for transp in Glue.-    primFaceForall : (I → I) → I   module _ {ℓ : I → Level} (P : (i : I) → Set (ℓ i)) where

src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda view

@@ -60,14 +60,20 @@   prim^unglueU : {la : Level} {φ : I} {T : I → Partial φ (Set la)}                    {A : Set la [ φ ↦ T i0 ]} →                    hcomp T (outS A) → outS A+  -- Needed for transp.+  primFaceForall : (I → I) → I -transpProof : ∀ {l} → (e : I → Set l) → (φ : I) → (a : Partial φ (e i0)) → (b : e i1 [ φ ↦ (\ o → transp e i0 (a o)) ] ) → fiber (transp e i0) (outS b)-transpProof e φ a b = f , \ j → comp e (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ i)) (~ i) (a 1=1)+transpProof : ∀ {l} → (e : I → Set l) → (φ : I) → (a : Partial φ (e i0)) → (b : e i1 [ φ ↦ (\ o → transp (\ i → e i) i0 (a o)) ] ) → fiber (transp (\ i → e i) i0) (outS b)+transpProof e φ a b = f , \ j → comp (\ i → e i) (\ i →+                                               \ { (φ = i1) → transp (\ j → e (j ∧ i)) (~ i) (a 1=1)                                                  ; (j = i0) → transp (\ j → e (j ∧ i)) (~ i) f                                                  ; (j = i1) → g (~ i) })                                         f     where-      g = fill (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1); (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) (outS b) }) (inS (outS b))-      f = comp (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1); (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) (outS b) }) (outS b)+      b' = outS {u = (\ o → transp (\ i → e i) i0 (a o))} b+      g : (k : I) → e (~ k)+      g k = fill (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1)+                                          ; (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) b' }) (inS b') k+      f = comp (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1); (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) b' }) b'  {-# BUILTIN TRANSPPROOF transpProof #-}

src/data/lib/prim/Agda/Builtin/Float.agda view

@@ -4,37 +4,207 @@ module Agda.Builtin.Float where  open import Agda.Builtin.Bool-open import Agda.Builtin.Nat open import Agda.Builtin.Int-open import Agda.Builtin.Word+open import Agda.Builtin.Maybe+open import Agda.Builtin.Nat+open import Agda.Builtin.Sigma open import Agda.Builtin.String+open import Agda.Builtin.Word  postulate Float : Set {-# BUILTIN FLOAT Float #-}  primitive-  primFloatToWord64 : Float → Word64-  primFloatEquality : Float → Float → Bool-  primFloatLess     : Float → Float → Bool-  primFloatNumericalEquality : Float → Float → Bool-  primFloatNumericalLess     : Float → Float → Bool-  primNatToFloat    : Nat → Float-  primFloatPlus     : Float → Float → Float-  primFloatMinus    : Float → Float → Float-  primFloatTimes    : Float → Float → Float-  primFloatNegate   : Float → Float-  primFloatDiv      : Float → Float → Float-  primFloatSqrt     : Float → Float-  primRound         : Float → Int-  primFloor         : Float → Int-  primCeiling       : Float → Int-  primExp           : Float → Float-  primLog           : Float → Float-  primSin           : Float → Float-  primCos           : Float → Float-  primTan           : Float → Float-  primASin          : Float → Float-  primACos          : Float → Float-  primATan          : Float → Float-  primATan2         : Float → Float → Float-  primShowFloat     : Float → String+  -- Relations+  primFloatInequality        : Float → Float → Bool+  primFloatEquality          : Float → Float → Bool+  primFloatLess              : Float → Float → Bool+  primFloatIsInfinite        : Float → Bool+  primFloatIsNaN             : Float → Bool+  primFloatIsNegativeZero    : Float → Bool+  primFloatIsSafeInteger     : Float → Bool+  -- Conversions+  primFloatToWord64          : Float → Word64+  primNatToFloat             : Nat → Float+  primIntToFloat             : Int → Float+  primFloatRound             : Float → Maybe Int+  primFloatFloor             : Float → Maybe Int+  primFloatCeiling           : Float → Maybe Int+  primFloatToRatio           : Float → (Σ Int λ _ → Int)+  primRatioToFloat           : Int → Int → Float+  primFloatDecode            : Float → Maybe (Σ Int λ _ → Int)+  primFloatEncode            : Int → Int → Maybe Float+  primShowFloat              : Float → String+  -- Operations+  primFloatPlus              : Float → Float → Float+  primFloatMinus             : Float → Float → Float+  primFloatTimes             : Float → Float → Float+  primFloatDiv               : Float → Float → Float+  primFloatPow               : Float → Float → Float+  primFloatNegate            : Float → Float+  primFloatSqrt              : Float → Float+  primFloatExp               : Float → Float+  primFloatLog               : Float → Float+  primFloatSin               : Float → Float+  primFloatCos               : Float → Float+  primFloatTan               : Float → Float+  primFloatASin              : Float → Float+  primFloatACos              : Float → Float+  primFloatATan              : Float → Float+  primFloatATan2             : Float → Float → Float+  primFloatSinh              : Float → Float+  primFloatCosh              : Float → Float+  primFloatTanh              : Float → Float+  primFloatASinh             : Float → Float+  primFloatACosh             : Float → Float+  primFloatATanh             : Float → Float++{-# COMPILE JS+    primFloatRound = function(x) {+        x = agdaRTS._primFloatRound(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+        }+    };+#-}+{-# COMPILE JS+    primFloatFloor = function(x) {+        x = agdaRTS._primFloatFloor(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+        }+    };+#-}+{-# COMPILE JS+    primFloatCeiling = function(x) {+        x = agdaRTS._primFloatCeiling(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+        }+    };+#-}+{-# COMPILE JS+    primFloatToRatio = function(x) {+        x = agdaRTS._primFloatToRatio(x);+        return z_jAgda_Agda_Builtin_Sigma["_,_"](x.numerator)(x.denominator);+    };+#-}+{-# COMPILE JS+    primFloatDecode = function(x) {+        x = agdaRTS._primFloatDecode(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](+                z_jAgda_Agda_Builtin_Sigma["_,_"](x.mantissa)(x.exponent));+        }+    };+#-}+{-# COMPILE JS+    primFloatEncode = function(x) {+        return function (y) {+            x = agdaRTS.uprimFloatEncode(x, y);+            if (x === null) {+                return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+            }+            else {+                return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+            }+        }+    };+#-}++primFloatNumericalEquality = primFloatEquality+{-# WARNING_ON_USAGE primFloatNumericalEquality+"Warning: primFloatNumericalEquality was deprecated in Agda v2.6.2.+Please use primFloatEquality instead."+#-}++primFloatNumericalLess = primFloatLess+{-# WARNING_ON_USAGE primFloatNumericalLess+"Warning: primFloatNumericalLess was deprecated in Agda v2.6.2.+Please use primFloatLess instead."+#-}++primRound = primFloatRound+{-# WARNING_ON_USAGE primRound+"Warning: primRound was deprecated in Agda v2.6.2.+Please use primFloatRound instead."+#-}++primFloor = primFloatFloor+{-# WARNING_ON_USAGE primFloor+"Warning: primFloor was deprecated in Agda v2.6.2.+Please use primFloatFloor instead."+#-}++primCeiling = primFloatCeiling+{-# WARNING_ON_USAGE primCeiling+"Warning: primCeiling was deprecated in Agda v2.6.2.+Please use primFloatCeiling instead."+#-}++primExp = primFloatExp+{-# WARNING_ON_USAGE primExp+"Warning: primExp was deprecated in Agda v2.6.2.+Please use primFloatExp instead."+#-}++primLog = primFloatLog+{-# WARNING_ON_USAGE primLog+"Warning: primLog was deprecated in Agda v2.6.2.+Please use primFloatLog instead."+#-}++primSin = primFloatSin+{-# WARNING_ON_USAGE primSin+"Warning: primSin was deprecated in Agda v2.6.2.+Please use primFloatSin instead."+#-}++primCos = primFloatCos+{-# WARNING_ON_USAGE primCos+"Warning: primCos was deprecated in Agda v2.6.2.+Please use primFloatCos instead."+#-}++primTan = primFloatTan+{-# WARNING_ON_USAGE primTan+"Warning: primTan was deprecated in Agda v2.6.2.+Please use primFloatTan instead."+#-}++primASin = primFloatASin+{-# WARNING_ON_USAGE primASin+"Warning: primASin was deprecated in Agda v2.6.2.+Please use primFloatASin instead."+#-}+++primACos = primFloatACos+{-# WARNING_ON_USAGE primACos+"Warning: primACos was deprecated in Agda v2.6.2.+Please use primFloatACos instead."+#-}++primATan = primFloatATan+{-# WARNING_ON_USAGE primATan+"Warning: primATan was deprecated in Agda v2.6.2.+Please use primFloatATan instead."+#-}++primATan2 = primFloatATan2+{-# WARNING_ON_USAGE primATan2+"Warning: primATan2 was deprecated in Agda v2.6.2.+Please use primFloatATan2 instead."+#-}

src/data/lib/prim/Agda/Builtin/List.agda view

@@ -10,7 +10,6 @@  {-# BUILTIN LIST List #-} -{-# COMPILE UHC List = data __LIST__ (__NIL__ | __CONS__) #-} {-# COMPILE JS  List = function(x,v) {   if (x.length < 1) { return v["[]"](); } else { return v["_∷_"](x[0], x.slice(1)); } } #-}

+ src/data/lib/prim/Agda/Builtin/Maybe.agda view

@@ -0,0 +1,10 @@+{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness+            --no-subtyping #-}++module Agda.Builtin.Maybe where++data Maybe {a} (A : Set a) : Set a where+  just : A → Maybe A+  nothing : Maybe A++{-# BUILTIN MAYBE Maybe #-}

src/data/lib/prim/Agda/Builtin/Reflection.agda view

@@ -13,6 +13,7 @@ open import Agda.Builtin.Float open import Agda.Builtin.Int open import Agda.Builtin.Sigma+open import Agda.Primitive  -- Names -- @@ -102,8 +103,23 @@ {-# BUILTIN RELEVANT   relevant   #-} {-# BUILTIN IRRELEVANT irrelevant #-} +-- Arguments also have a quantity.+data Quantity : Set where+  quantity-0 quantity-ω : Quantity++{-# BUILTIN QUANTITY   Quantity   #-}+{-# BUILTIN QUANTITY-0 quantity-0 #-}+{-# BUILTIN QUANTITY-ω quantity-ω #-}++-- Relevance and quantity are combined into a modality.+data Modality : Set where+  modality : (r : Relevance) (q : Quantity) → Modality++{-# BUILTIN MODALITY             Modality #-}+{-# BUILTIN MODALITY-CONSTRUCTOR modality #-}+ data ArgInfo : Set where-  arg-info : (v : Visibility) (r : Relevance) → ArgInfo+  arg-info : (v : Visibility) (m : Modality) → ArgInfo  data Arg {a} (A : Set a) : Set a where   arg : (i : ArgInfo) (x : A) → Arg A@@ -141,29 +157,13 @@ {-# BUILTIN AGDALITQNAME  name    #-} {-# BUILTIN AGDALITMETA   meta    #-} --- Patterns -- -data Pattern : Set where-  con    : (c : Name) (ps : List (Arg Pattern)) → Pattern-  dot    : Pattern-  var    : (s : String)  → Pattern-  lit    : (l : Literal) → Pattern-  proj   : (f : Name)    → Pattern-  absurd : Pattern--{-# BUILTIN AGDAPATTERN   Pattern #-}-{-# BUILTIN AGDAPATCON    con     #-}-{-# BUILTIN AGDAPATDOT    dot     #-}-{-# BUILTIN AGDAPATVAR    var     #-}-{-# BUILTIN AGDAPATLIT    lit     #-}-{-# BUILTIN AGDAPATPROJ   proj    #-}-{-# BUILTIN AGDAPATABSURD absurd  #-}---- Terms --+-- Terms and patterns -- -data Sort   : Set-data Clause : Set-data Term   : Set+data Term    : Set+data Sort    : Set+data Pattern : Set+data Clause  : Set Type = Term  data Term where@@ -181,15 +181,27 @@ data Sort where   set     : (t : Term) → Sort   lit     : (n : Nat) → Sort+  prop    : (t : Term) → Sort+  propLit : (n : Nat) → Sort+  inf     : (n : Nat) → Sort   unknown : Sort +data Pattern where+  con    : (c : Name) (ps : List (Arg Pattern)) → Pattern+  dot    : (t : Term)    → Pattern+  var    : (x : Nat)     → Pattern+  lit    : (l : Literal) → Pattern+  proj   : (f : Name)    → Pattern+  absurd : (x : Nat)     → Pattern  -- absurd patterns counts as variables+ data Clause where-  clause        : (ps : List (Arg Pattern)) (t : Term) → Clause-  absurd-clause : (ps : List (Arg Pattern)) → Clause+  clause        : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) (t : Term) → Clause+  absurd-clause : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) → Clause -{-# BUILTIN AGDASORT    Sort   #-}-{-# BUILTIN AGDATERM    Term   #-}-{-# BUILTIN AGDACLAUSE  Clause #-}+{-# BUILTIN AGDATERM      Term    #-}+{-# BUILTIN AGDASORT      Sort    #-}+{-# BUILTIN AGDAPATTERN   Pattern #-}+{-# BUILTIN AGDACLAUSE    Clause  #-}  {-# BUILTIN AGDATERMVAR         var       #-} {-# BUILTIN AGDATERMCON         con       #-}@@ -204,8 +216,18 @@  {-# BUILTIN AGDASORTSET         set     #-} {-# BUILTIN AGDASORTLIT         lit     #-}+{-# BUILTIN AGDASORTPROP        prop    #-}+{-# BUILTIN AGDASORTPROPLIT     propLit #-}+{-# BUILTIN AGDASORTINF         inf     #-} {-# BUILTIN AGDASORTUNSUPPORTED unknown #-} +{-# BUILTIN AGDAPATCON    con     #-}+{-# BUILTIN AGDAPATDOT    dot     #-}+{-# BUILTIN AGDAPATVAR    var     #-}+{-# BUILTIN AGDAPATLIT    lit     #-}+{-# BUILTIN AGDAPATPROJ   proj    #-}+{-# BUILTIN AGDAPATABSURD absurd  #-}+ {-# BUILTIN AGDACLAUSECLAUSE clause        #-} {-# BUILTIN AGDACLAUSEABSURD absurd-clause #-} @@ -254,6 +276,7 @@   catchTC          : ∀ {a} {A : Set a} → TC A → TC A → TC A   quoteTC          : ∀ {a} {A : Set a} → A → TC Term   unquoteTC        : ∀ {a} {A : Set a} → Term → TC A+  quoteωTC         : ∀ {A : Setω} → A → TC Term   getContext       : TC (List (Arg Type))   extendContext    : ∀ {a} {A : Set a} → Arg Type → TC A → TC A   inContext        : ∀ {a} {A : Set a} → List (Arg Type) → TC A → TC A@@ -271,10 +294,20 @@   -- their results: inferType, checkType, quoteTC, getType, and getContext   withNormalisation : ∀ {a} {A : Set a} → Bool → TC A → TC A +  -- Makes the following primitives to reconstruct hidden arguments+  -- getDefinition, normalise, reduce, inferType, checkType and getContext+  withReconstructed : ∀ {a} {A : Set a} → TC A → TC A+   -- Prints the third argument if the corresponding verbosity level is turned   -- on (with the -v flag to Agda).   debugPrint : String → Nat → List ErrorPart → TC ⊤ +  -- Only allow reduction of specific definitions while executing the TC computation+  onlyReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A++  -- Don't allow reduction of specific definitions while executing the TC computation+  dontReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A+   -- Fail if the given computation gives rise to new, unsolved   -- "blocking" constraints.   noConstraints : ∀ {a} {A : Set a} → TC A → TC A@@ -296,6 +329,7 @@ {-# BUILTIN AGDATCMCATCHERROR                 catchTC                    #-} {-# BUILTIN AGDATCMQUOTETERM                  quoteTC                    #-} {-# BUILTIN AGDATCMUNQUOTETERM                unquoteTC                  #-}+{-# BUILTIN AGDATCMQUOTEOMEGATERM             quoteωTC                   #-} {-# BUILTIN AGDATCMGETCONTEXT                 getContext                 #-} {-# BUILTIN AGDATCMEXTENDCONTEXT              extendContext              #-} {-# BUILTIN AGDATCMINCONTEXT                  inContext                  #-}@@ -310,5 +344,8 @@ {-# BUILTIN AGDATCMISMACRO                    isMacro                    #-} {-# BUILTIN AGDATCMWITHNORMALISATION          withNormalisation          #-} {-# BUILTIN AGDATCMDEBUGPRINT                 debugPrint                 #-}+{-# BUILTIN AGDATCMONLYREDUCEDEFS             onlyReduceDefs             #-}+{-# BUILTIN AGDATCMDONTREDUCEDEFS             dontReduceDefs             #-}+{-# BUILTIN AGDATCMWITHRECONSPARAMS           withReconstructed          #-} {-# BUILTIN AGDATCMNOCONSTRAINTS              noConstraints              #-} {-# BUILTIN AGDATCMRUNSPECULATIVE             runSpeculative             #-}

+ src/data/lib/prim/Agda/Builtin/Reflection/External.agda view

@@ -0,0 +1,15 @@+{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness --no-subtyping #-}++module Agda.Builtin.Reflection.External where++open import Agda.Builtin.List+open import Agda.Builtin.Nat+open import Agda.Builtin.Sigma+open import Agda.Builtin.String+open import Agda.Builtin.Reflection++postulate+  execTC : String → List String → String+         → TC (Σ Nat (λ _ → Σ String (λ _ → String)))++{-# BUILTIN AGDATCMEXEC execTC #-}

src/data/lib/prim/Agda/Builtin/Size.agda view

@@ -1,14 +1,14 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism --sized-types+{-# OPTIONS --without-K --no-universe-polymorphism --sized-types             --no-guardedness --no-subtyping #-}  module Agda.Builtin.Size where -{-# BUILTIN SIZEUNIV SizeU #-}-{-# BUILTIN SIZE     Size   #-}-{-# BUILTIN SIZELT   Size<_ #-}-{-# BUILTIN SIZESUC  ↑_     #-}-{-# BUILTIN SIZEINF  ∞      #-}-{-# BUILTIN SIZEMAX  _⊔ˢ_  #-}+{-# BUILTIN SIZEUNIV SizeUniv #-}+{-# BUILTIN SIZE     Size     #-}+{-# BUILTIN SIZELT   Size<_   #-}+{-# BUILTIN SIZESUC  ↑_       #-}+{-# BUILTIN SIZEINF  ∞        #-}+{-# BUILTIN SIZEMAX  _⊔ˢ_     #-}  {-# FOREIGN GHC   type SizeLT i = ()

src/data/lib/prim/Agda/Builtin/String.agda view

@@ -4,14 +4,17 @@ module Agda.Builtin.String where  open import Agda.Builtin.Bool-open import Agda.Builtin.List open import Agda.Builtin.Char+open import Agda.Builtin.List+open import Agda.Builtin.Maybe open import Agda.Builtin.Nat using (Nat)+open import Agda.Builtin.Sigma  postulate String : Set {-# BUILTIN STRING String #-}  primitive+  primStringUncons   : String → Maybe (Σ Char (λ _ → String))   primStringToList   : String → List Char   primStringFromList : List Char → String   primStringAppend   : String → String → String@@ -20,9 +23,15 @@   primShowString     : String → String   primShowNat        : Nat → String +{-# COMPILE JS primStringUncons = function(x) {+   if (x === "") { return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"]; };+   return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](z_jAgda_Agda_Builtin_Sigma["_,_"](x.charAt(0))(x.slice(1)));+   }+ #-} {-# COMPILE JS primStringToList = function(x) { return x.split(""); } #-} {-# COMPILE JS primStringFromList = function(x) { return x.join(""); } #-} {-# COMPILE JS primStringAppend = function(x) { return function(y) { return x+y; }; } #-} {-# COMPILE JS primStringEquality = function(x) { return function(y) { return x===y; }; } #-} {-# COMPILE JS primShowChar = function(x) { return JSON.stringify(x); } #-} {-# COMPILE JS primShowString = function(x) { return JSON.stringify(x); } #-}+{-# COMPILE JS primShowNat = function(x) { return JSON.stringify(x); } #-}

src/data/lib/prim/Agda/Builtin/String/Properties.agda view

@@ -9,3 +9,4 @@ primitive    primStringToListInjective : ∀ a b → primStringToList a ≡ primStringToList b → a ≡ b+  primStringFromListInjective : ∀ a b → primStringFromList a ≡ primStringFromList b → a ≡ b

src/data/lib/prim/Agda/Primitive.agda view

@@ -1,6 +1,6 @@ -- The Agda primitives (preloaded). -{-# OPTIONS --without-K --no-subtyping #-}+{-# OPTIONS --without-K --no-subtyping --no-import-sorts #-}  module Agda.Primitive where @@ -10,6 +10,12 @@  infixl 6 _⊔_ +{-# BUILTIN TYPE Set #-}+{-# BUILTIN PROP Prop #-}+{-# BUILTIN SETOMEGA Setω #-}+{-# BUILTIN STRICTSET      SSet  #-}+{-# BUILTIN STRICTSETOMEGA SSetω #-}+ -- Level is the first thing we need to define. -- The other postulates can only be checked if built-in Level is known. @@ -29,5 +35,3 @@ {-# BUILTIN LEVELZERO lzero #-} {-# BUILTIN LEVELSUC  lsuc  #-} {-# BUILTIN LEVELMAX  _⊔_   #-}--{-# BUILTIN SETOMEGA Setω #-}

src/full/Agda/Auto/Auto.hs view

@@ -7,7 +7,9 @@  import Prelude hiding (null) +import Control.Monad.Except import Control.Monad.State+ import qualified Data.List as List import qualified Data.Map as Map import Data.IORef@@ -47,7 +49,6 @@  import Agda.Auto.CaseSplit -import Agda.Utils.Except ( runExceptT, MonadError(catchError) ) import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Lens@@ -190,7 +191,8 @@                  nsol' <- readIORef nsol                  if nsol' /= 0 && depreached then loop (d + costIncrease) else return depreached -        let getsols sol = do+        let getsols :: [I.Term] -> TCM [(MetaId, A.Expr)]+            getsols sol = do              exprs <- forM (zip (Map.keys tccons) sol) $ \ (mi, e) -> do                mv   <- lookupMeta mi                e    <- etaContract e@@ -223,7 +225,7 @@                     sctx = (Id "h", closify htyp) : map (\x -> (NoId, closify x)) modargs                     ntt = closify (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil))                 res <- exsearch (tcSearchSC False sctx ntt (Meta m)) Nothing defdfv-                rsols <- liftM reverse $ liftIO $ readIORef sols+                rsols <- fmap reverse $ liftIO $ readIORef sols                 if null rsols then do                   nsol' <- liftIO $ readIORef nsol                   stopWithMsg $ insuffsols (pick + numsols - nsol')@@ -235,7 +237,7 @@                       (mi,) <$> abstractToConcrete_ e                   let ss = dropWhile (== ' ') . dropWhile (/= ' ') . prettyShow                       disp [(_, cexpr)] = ss cexpr-                      disp cexprs = concat $ map (\ (mi, cexpr) -> ss cexpr ++ " ") cexprs+                      disp cexprs = concatMap (\ (mi, cexpr) -> ss cexpr ++ " ") cexprs                   ticks <- liftIO $ readIORef ticks                   stopWithMsg $ unlines $                     ("Listing disproof(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1)) :@@ -277,7 +279,7 @@           let timeoutString | isNothing res = " after timeout (" ++ show timeout ++ "ms)"                             | otherwise     = ""           if listmode then do-            rsols <- liftM reverse $ liftIO $ readIORef sols+            rsols <- fmap reverse $ liftIO $ readIORef sols             if null rsols then do               nsol' <- liftIO $ readIORef nsol               stopWithMsg $ insuffsols (pick + numsols - nsol') ++ timeoutString@@ -296,7 +298,7 @@                       ++ " := " ++ prettyShow cexpr ++ " "               ticks <- liftIO $ readIORef ticks               stopWithMsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++-                        "\n" ++ unlines (map (\(x, y) -> show y ++ "  " ++ disp x) $ zip cexprss [pick..])+                        "\n" ++ unlines (zipWith (\x y -> show y ++ "  " ++ disp x) cexprss [pick..])            else {- not listmode -}             case res of              Nothing -> do@@ -351,7 +353,7 @@                                          ) exprs                       let msgs = catMaybes $ msg : map snd giveress                           msg' = unlines msgs <$ guard (not $ null msgs)-                      return $ AutoResult (Solutions $ catMaybes $ map fst giveress) msg'+                      return $ AutoResult (Solutions $ mapMaybe fst giveress) msg'       MCaseSplit -> do       case thisdefinfo of@@ -359,7 +361,7 @@         case Map.elems tccons of          [(m, mytype, mylocalVars, _)] | null eqcons -> do           (ids, pats) <- constructPats cmap mi clause-          let ctx = map (\((hid, id), t) -> HI hid (id, t)) (zip ids mylocalVars)+          let ctx = zipWith (\(hid, id) t -> HI hid (id, t)) ids mylocalVars           ticks <- liftIO $ newIORef 0           let [rectyp'] = mymrectyp           defdfv <- getdfv mi def@@ -377,12 +379,12 @@             case cls' of              Left{} -> stopWithMsg "No solution found"              Right cls' -> do-              cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall recursive reachable ell) -> do+              cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall exact recursive reachable ell) -> do                 withCurrentModule (AN.qnameModule def) $ do                  -- Normalise the dot patterns                  ps <- addContext tel $ normalise ps                  body <- etaContract body-                 liftM modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange noRange tel ps body t catchall recursive reachable ell+                 fmap modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange noRange tel ps body t catchall exact recursive reachable ell               moduleTel <- lookupSection (AN.qnameModule def)               pcs <- withInteractionId ii $ inTopContext $ addContext moduleTel $ mapM prettyA cls''               ticks <- liftIO $ readIORef ticks@@ -405,12 +407,12 @@        normalise targettype       let tctx = length $ envContext $ clEnv minfo -      hits <- if elem "-a" hints then do+      hits <- if "-a" `elem` hints then do         st <- liftTCM $ join $ pureTCM $ \st _ -> return st         let defs = st^.stSignature.sigDefinitions             idefs = st^.stImports.sigDefinitions             alldefs = HMap.keys defs ++ HMap.keys idefs-        liftM catMaybes $ mapM (\n ->+        catMaybes <$> mapM (\n ->           case thisdefinfo of            Just (def, _, _) | def == n -> return Nothing            _ -> do@@ -433,7 +435,7 @@             modnames = case thisdefinfo of                         Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames                         Nothing -> qnames-        liftM catMaybes $ mapM (\(cn, n) -> do+        catMaybes <$> mapM (\(cn, n) -> do           c <- getConstInfo n           ctyp <- normalise $ defType c           cdfv <- withMetaInfo minfo $ getDefFreeVars n@@ -450,7 +452,7 @@             else              let showhits = take 10 $ drop pick' sorthits              in stopWithMsg $ "Listing candidate(s) " ++ show pick' ++ "-" ++ show (pick' + length showhits - 1) ++ " (found " ++ show (length sorthits) ++ " in total)\n" ++-                           unlines (map (\(i, (cn, _)) -> show i ++ "  " ++ cn) (zip [pick'..pick' + length showhits - 1] showhits))+                           unlines (zipWith (\i (cn, _) -> show i ++ "  " ++ cn) [pick'..pick' + length showhits - 1] showhits)        else         if pick >= length sorthits then          stopWithMsg $ insuffcands $ length sorthits@@ -491,10 +493,10 @@ -- | Templates for error messages  genericNotEnough :: String -> Int -> String-genericNotEnough str n = List.intercalate " " $ case n of-  0 -> [ "No"    , str, "found"]-  1 -> [ "Only 1", str, "found" ]-  _ -> [ "Only", show n, str ++ "s", "found" ]+genericNotEnough str n = unwords $ case n of+  0 -> ["No", str, "found"]+  1 -> ["Only 1", str, "found"]+  _ -> ["Only", show n, str ++ "s", "found"]  insuffsols :: Int -> String insuffsols  = genericNotEnough "solution"

src/full/Agda/Auto/CaseSplit.hs view

@@ -1,12 +1,11 @@-{-# LANGUAGE UndecidableInstances #-}  module Agda.Auto.CaseSplit where  import Data.IORef import Data.Tuple (swap)-import Data.List (findIndex)+import Data.List (elemIndex)+-- Import of <> needed for 8.2.2, but redundant in 8.8.3 import Data.Monoid ((<>), Sum(..))-import Data.Foldable (foldMap) import qualified Data.Set    as Set import qualified Data.IntMap as IntMap import Control.Monad.State as St hiding (lift)@@ -23,6 +22,7 @@  import Agda.Utils.Impossible import Agda.Utils.Monad (or2M)+import Agda.Utils.List (last1)  abspatvarname :: String abspatvarname = "\0absurdPattern"@@ -80,8 +80,7 @@                       , rieEqReasoningConsts = meqr                       }       depreached <- topSearch ticks nsol hsol env initcon depth (depth + 1)-      rsol <- readIORef sol-      return rsol+      readIORef sol      ctx' = ff 1 ctx      ff _ [] = []      ff n (HI hid (id, t) : ctx) = HI hid (id, lift n t) : ff (n + 1) ctx@@ -92,8 +91,7 @@   Int -> Cost -> ConstRef o -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o] caseSplitSearch' branchsearch depthinterval depth recdef ctx tt pats = do   recdefd <- readIORef recdef-  sols <- rc depth (cddeffreevars recdefd) ctx tt pats-  return sols+  rc depth (cddeffreevars recdefd) ctx tt pats  where   rc :: Cost -> Int -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o]   rc depth _ _ _ _ | depth < 0 = return []@@ -164,9 +162,9 @@               thesub = replace scrut (length newvars) constrapp               Id newvarprefix = fst $ (drophid ctx) !! scrut               ctx1 = map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (take scrut ctx) ++-                     reverse (map (\(((hid, _), id, t), i) ->+                     reverse (zipWith (\((hid, _), id, t) i ->                        HI hid (Id (case id of {NoId -> newvarprefix{- ++ show i-}; Id id -> id}), t)-                      ) (zip newvars [0..])) +++                      ) newvars [0..]) ++                      map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (drop (scrut + 1) ctx)               tt' = thesub tt               pats' = map (replacep scrut (length newvars) pconstrapp constrapp) pats@@ -182,13 +180,15 @@             do              let (ctx2, tt2, pats2) = removevar ctx1 tt' pats' unif                  --cost = if elem scrut mblkvar then costCaseSplit - (costCaseSplit - costCaseSplitFollow) `div` (length mblkvar) else costCaseSplit-                 cost = if null mblkvar then-                         if scrut < length ctx - nscrutavoid && nothid-                         then costCaseSplitLow + costAddVarDepth-                              * Cost (depthofvar scrut pats)-                         else costCaseSplitVeryHigh-                        else-                         if scrut `elem` mblkvar then costCaseSplitLow else (if scrut < length ctx - nscrutavoid && nothid then costCaseSplitHigh else costCaseSplitVeryHigh)+                 cost+                   | null mblkvar && scrut < length ctx - nscrutavoid && nothid+                                                                = costCaseSplitLow ++                                                                  costAddVarDepth *+                                                                  Cost (depthofvar scrut pats)+                   | null mblkvar                               = costCaseSplitVeryHigh+                   | scrut `elem` mblkvar                       = costCaseSplitLow+                   | scrut < length ctx - nscrutavoid && nothid = costCaseSplitHigh+                   | otherwise                                  = costCaseSplitVeryHigh                   nothid = let HI hid _ = ctx !! scrut                           in hid == NotHidden@@ -199,24 +199,27 @@               [] -> return []               _ -> do                sols2 <- dobranches cons-               return $ concat (map (\sol -> map (\sol2 -> sol ++ sol2) sols2) sols)+               return $ concatMap (\sol -> map (\sol2 -> sol ++ sol2) sols2) sols        _ -> return [] -- split failed "scrut type is not datatype"      _ -> return [] -- split failed "scrut type is not datatype"  infertypevar :: CSCtx o -> Nat -> MExp o infertypevar ctx v = snd $ (drophid ctx) !! v -class Replace o t u | t u -> o where-  replace' :: Nat -> MExp o -> t -> Reader (Nat, Nat) u+class Replace t u where+  type ReplaceWith t u+  replace' :: Nat -> MExp (ReplaceWith t u) -> t -> Reader (Nat, Nat) u -replace :: Replace o t u => Nat -> Nat -> MExp o -> t -> u+replace :: Replace t u => Nat -> Nat -> MExp (ReplaceWith t u) -> t -> u replace sv nnew e t = replace' 0 e t `runReader` (sv, nnew) -instance Replace o t u => Replace o (Abs t) (Abs u) where+instance Replace t u => Replace (Abs t) (Abs u) where+  type ReplaceWith (Abs t) (Abs u) = ReplaceWith t u   replace' n re (Abs mid b) = Abs mid <$> replace' (n + 1) re b -instance Replace o (Exp o) (MExp o) where-  replace' n re e = case e of+instance Replace (Exp o) (MExp o) where+  type ReplaceWith (Exp o) (MExp o) = o+  replace' n re = \case     App uid ok elr@(Var v) args -> do       ih         <- NotM <$> replace' n re args       (sv, nnew) <- ask@@ -233,13 +236,15 @@     Lam hid b -> NotM . Lam hid <$> replace' (n + 1) re b     Pi uid hid possdep it b ->       fmap NotM $ Pi uid hid possdep <$> replace' n re it <*> replace' n re b-    Sort{} -> return $ NotM e-    AbsurdLambda{} -> return $ NotM e+    e@Sort{} -> return $ NotM e+    e@AbsurdLambda{} -> return $ NotM e -instance Replace o t u => Replace o (MM t (RefInfo o)) u where+instance Replace t u => Replace (MM t (RefInfo o)) u where+  type ReplaceWith (MM t (RefInfo o)) u = ReplaceWith t u   replace' n re = replace' n re . rm __IMPOSSIBLE__ -instance Replace o (ArgList o) (ArgList o) where+instance Replace (ArgList o) (ArgList o) where+  type ReplaceWith (ArgList o) (ArgList o) = o   replace' n re args = case args of     ALNil           -> return ALNil     ALCons hid a as ->@@ -273,13 +278,9 @@  where   r :: CSPat o -> CSPat o   r (HI hid (CSPatConApp c ps)) = HI hid (CSPatConApp c (map r ps))-  r (HI hid (CSPatVar v)) = if v == sv then-                    HI hid rp-                   else-                    if v > sv then-                     HI hid (CSPatVar (v + nnew - 1))-                    else-                     HI hid (CSPatVar v)+  r (HI hid (CSPatVar v)) | v == sv   = HI hid rp+                          | v > sv    = HI hid (CSPatVar (v + nnew - 1))+                          | otherwise = HI hid (CSPatVar v)   r (HI hid (CSPatExp e)) = HI hid (CSPatExp $ replace sv nnew re e)    r p@(HI _ CSOmittedArg) = p@@ -293,18 +294,21 @@  type Assignments o = [(Nat, Exp o)] -class Unify o t | t -> o where-  unify'    :: t -> t -> StateT (Assignments o) Maybe ()-  notequal' :: t -> t -> ReaderT (Nat, Nat) (StateT (Assignments o) IO) Bool+class Unify t where+  type UnifiesTo t+  unify'    :: t -> t -> StateT (Assignments (UnifiesTo t)) Maybe ()+  notequal' :: t -> t -> ReaderT (Nat, Nat) (StateT (Assignments (UnifiesTo t)) IO) Bool -unify :: Unify o t => t -> t -> Maybe (Assignments o)+unify :: Unify t => t -> t -> Maybe (Assignments (UnifiesTo t)) unify t u = unify' t u `execStateT` [] -notequal :: Unify o t => Nat -> Nat -> t -> t -> IO Bool+notequal :: Unify t => Nat -> Nat -> t -> t -> IO Bool notequal fstnew nbnew t1 t2 = notequal' t1 t2 `runReaderT` (fstnew, nbnew)                                               `evalStateT` [] -instance Unify o t => Unify o (MM t (RefInfo o)) where+instance (Unify t, o ~ UnifiesTo t) => Unify (MM t (RefInfo o)) where+  type UnifiesTo (MM t (RefInfo o)) = o+   unify' = unify' `on` rm __IMPOSSIBLE__    notequal' = notequal' `on` rm __IMPOSSIBLE__@@ -316,12 +320,15 @@     Nothing -> modify ((v, e) :)     Just e' -> unify' e e' -instance Unify o t => Unify o (Abs t) where+instance Unify t => Unify (Abs t) where+  type UnifiesTo (Abs t) = UnifiesTo t   unify' (Abs _ b1) (Abs _ b2) = unify' b1 b2    notequal' (Abs _ b1) (Abs _ b2) = notequal' b1 b2 -instance Unify o (Exp o) where+instance Unify (Exp o) where+  type UnifiesTo (Exp o) = o+   unify' e1 e2 = case (e1, e2) of    (App _ _ elr1 args1, App _ _ elr2 args2) | elr1 == elr2 -> unify' args1 args2    (Lam hid1 b1, Lam hid2 b2)               | hid1 == hid2 -> unify' b1 b2@@ -365,7 +372,9 @@ -}       _ -> return False -instance Unify o (ArgList o) where+instance Unify (ArgList o) where+  type UnifiesTo (ArgList o) = o+   unify' args1 args2 = case (args1, args2) of    (ALNil, ALNil) -> pure ()    (ALCons hid1 a1 as1, ALCons hid2 a2 as2) | hid1 == hid2 -> unify' a1 a2@@ -398,14 +407,14 @@   lift' n j = NotM . lift' n j . rm __IMPOSSIBLE__  instance Lift (Exp o) where-  lift' n j e = case e of+  lift' n j = \case     App uid ok elr args -> case elr of       Var v | v >= j -> App uid ok (Var (v + n)) (lift' n j args)       _ -> App uid ok elr (lift' n j args)     Lam hid b -> Lam hid (lift' n j b)     Pi uid hid possdep it b -> Pi uid hid possdep (lift' n j it) (lift' n j b)-    Sort{} -> e-    AbsurdLambda{} -> e+    e@Sort{} -> e+    e@AbsurdLambda{} -> e  instance Lift (ArgList o) where   lift' n j args = case args of@@ -461,17 +470,17 @@  in (ctx3, tt', pats')  ren :: [Nat] -> Nat -> Int-ren n i = let Just j = findIndex (== i) n in j+ren n i = let Just j = elemIndex i n in j  instance Renaming t => Renaming (HI t) where   renameOffset j ren (HI hid t) = HI hid $ renameOffset j ren t  instance Renaming (CSPatI o) where-  renameOffset j ren e = case e of+  renameOffset j ren = \case     CSPatConApp c pats -> CSPatConApp c $ map (renameOffset j ren) pats     CSPatVar i         -> CSPatVar $ j + ren i     CSPatExp e         -> CSPatExp $ renameOffset j ren e-    CSOmittedArg       -> e+    e@CSOmittedArg     -> e     _                  -> __IMPOSSIBLE__  seqctx :: CSCtx o -> CSCtx o@@ -485,7 +494,7 @@ depthofvar v pats =  let [depth] = concatMap (f 0) (drophid pats)      f d (CSPatConApp _ pats) = concatMap (f (d + 1)) (drophid pats)-     f d (CSPatVar v') = if v == v' then [d] else []+     f d (CSPatVar v') = [d | v == v']      f _ _ = []  in depth @@ -499,7 +508,7 @@   sizeAndBoundVars (HI _ p) = sizeAndBoundVars p  instance LocalTerminationEnv (CSPatI o) where-  sizeAndBoundVars p = case p of+  sizeAndBoundVars = \case     CSPatConApp _ ps -> (1, []) <> sizeAndBoundVars ps     CSPatVar n       -> (0, [n])     CSPatExp e       -> sizeAndBoundVars e@@ -637,7 +646,7 @@    _ -> return []  where   f blks = case blks of-             (_:_) -> case rawValue (last blks) of+             (b : bs) -> case rawValue (last1 b bs) of               HNApp (Var v) _ -> Just v               _ -> Nothing              _ -> Nothing

src/full/Agda/Auto/Convert.hs view

@@ -1,12 +1,14 @@  module Agda.Auto.Convert where +import Control.Monad.Except import Control.Monad.State++import Data.Bifunctor (first) import Data.IORef import Data.Maybe (catMaybes) import Data.Map (Map) import qualified Data.Map as Map-import Data.Traversable (traverse)  import Agda.Syntax.Common (Hiding(..), getHiding, Arg) import Agda.Syntax.Concrete (exprFieldA)@@ -42,7 +44,6 @@ import Agda.Auto.CaseSplit hiding (lift)  import Agda.Utils.Either-import Agda.Utils.Except      ( ExceptT , MonadError(throwError) ) import Agda.Utils.Lens import Agda.Utils.Monad       ( forMaybeMM ) import Agda.Utils.Permutation ( Permutation(Perm), permute, takeP, compactP )@@ -100,7 +101,7 @@    nxt <- popMapS sConsts (\x y -> y {sConsts = x})    case nxt of     Just cn -> do-     cmap <- fst `liftM` gets sConsts+     cmap <- gets (fst . sConsts)      let (mode, c) = cmap Map.! cn      def <- lift $ getConstInfo cn      let typ = MB.defType def@@ -121,6 +122,7 @@       MB.Function {MB.funClauses = clauses} -> clausesToDef clauses       -- MB.Primitive {MB.primClauses = []} -> throwError $ strMsg "Auto: Primitive functions are not supported" -- Andreas, 2013-06-17 breaks interaction/AutoMisc       MB.Primitive {MB.primClauses = clauses} -> clausesToDef clauses+      MB.PrimitiveSort{} -> __IMPOSSIBLE__       MB.Datatype {MB.dataCons = cons} -> do        cons2 <- mapM (\con -> getConst True con TMAll) cons        return (Datatype cons2 [], [])@@ -137,7 +139,8 @@        let Datatype [con] [] = cdcont cc        lift $ liftIO $ modifyIORef con (\cdef -> cdef {cdtype = contyp'}) -       projfcns <- mapM (\name -> getConst False name TMAll) (map I.unDom fields)+       projfcns <- mapM (\ dom -> getConst False (I.unDom dom) TMAll) fields+       -- Equivalently projfcns <- mapM (($ TMAll) . getConst False . I.unDom) fields         return (Datatype [con] projfcns, []{-map snd fields-})       MB.Constructor {MB.conData = dt} -> do@@ -171,7 +174,7 @@         Just sol -> do          m <- getMeta mi          sol' <- convert sol-         modify $ \s -> s {sEqs = (Map.insert (Map.size (fst $ sEqs s)) (Just (False, Meta m, sol')) (fst $ sEqs s), snd $ sEqs s)}+         modify $ \s -> s {sEqs = first (Map.insert (Map.size (fst $ sEqs s)) (Just (False, Meta m, sol'))) (sEqs s)}        let tt = MB.jMetaType $ mvJudgement mv            minfo = getMetaInfo mv            localVars = map (snd . I.unDom) . envContext . clEnv $ minfo@@ -185,7 +188,7 @@        typ' <- convert targettype        ctx' <- mapM convert localVars        modify (\s -> s {sCurMeta = Nothing})-       modify (\s -> s {sMetas = (Map.adjust (\(m, _, deps) -> (m, Just (typ', ctx'), deps)) mi (fst $ sMetas s), snd $ sMetas s)})+       modify (\s -> s {sMetas = first (Map.adjust (\(m, _, deps) -> (m, Just (typ', ctx'), deps)) mi) (sMetas s)})        r projfcns       Nothing -> do        nxt <- popMapS sEqs (\x y -> y {sEqs = x})@@ -194,7 +197,7 @@          let (ineq, e, i) = eqs !! eqi          e' <- convert e          i' <- convert i-         modify (\s -> s {sEqs = (Map.adjust (\_ -> Just (ineq, e', i')) eqi (fst $ sEqs s), snd $ sEqs s)})+         modify (\s -> s {sEqs = first (Map.adjust (\_ -> Just (ineq, e', i')) eqi) (sEqs s)})          r projfcns         Nothing ->          return projfcns@@ -223,7 +226,7 @@   MB.Record {MB.recConHead = con} -> do    let conname = I.conName con        conflds = I.conFields con-   cmap <- fst `liftM` gets sConsts+   cmap <- gets (fst . sConsts)    case Map.lookup name cmap of     Just (mode', c) ->      if iscon then do@@ -241,7 +244,7 @@      modify (\s -> s {sConsts = (Map.insert name (mode, c) cmap, name : snd (sConsts s))})      return $ if iscon then ccon else c   _ -> do-   cmap <- fst `liftM` gets sConsts+   cmap <- gets (fst . sConsts)    case Map.lookup name cmap of     Just (mode', c) ->      return c@@ -264,7 +267,7 @@  getMeta :: I.MetaId -> TOM (Metavar (Exp O) (RefInfo O)) getMeta name = do- mmap <- fst `liftM` gets sMetas+ mmap <- gets (fst . sMetas)  case Map.lookup name mmap of   Just (m, _, _) ->    return m@@ -281,7 +284,6 @@       ei <- etaContract i       ee <- etaContract e       return $ Just (tomyIneq ineq, ee, ei)-    MB.Guarded (MB.UnBlock _) _pid -> return Nothing     _ -> return Nothing  copatternsNotImplemented :: MB.TCM a@@ -320,8 +322,8 @@  instance Conversion TOM (Cm.Arg I.Pattern) (Pat O) where   convert p = case Cm.unArg p of-    I.IApplyP _ _ _ n  -> return $ PatVar (show n)-    I.VarP _ n  -> return $ PatVar (show n)+    I.IApplyP _ _ _ n  -> return $ PatVar (prettyShow n)+    I.VarP _ n  -> return $ PatVar (prettyShow n)     I.DotP _ _  -> return $ PatVar "_"       -- because Agda includes these when referring to variables in the body     I.ConP con _ pats -> do@@ -388,9 +390,7 @@             case mcurmeta of               Nothing -> return ()               Just curmeta ->-                modify $ \ s -> s { sMetas = ( Map.adjust (\(m, x, deps) -> (m, x, mid : deps)) curmeta (fst $ sMetas s)-                                           , snd $ sMetas s-                                           ) }+                modify $ \ s -> s { sMetas = first (Map.adjust (\(m, x, deps) -> (m, x, mid : deps)) curmeta) (sMetas s) }             m <- getMeta mid             return $ Meta m           _ -> convert t@@ -426,15 +426,10 @@ fmExp _ I.Dummy{} = False  fmExps :: I.MetaId -> I.Args -> Bool-fmExps m [] = False-fmExps m (a : as) = fmExp m (Cm.unArg a) || fmExps m as+fmExps m as = any (fmExp m . Cm.unArg) as  fmLevel :: I.MetaId -> I.PlusLevel -> Bool-fmLevel m (I.Plus _ l) = case l of-  I.MetaLevel m' _   -> m == m'-  I.NeutralLevel _ v -> fmExp m v-  I.BlockedLevel _ v -> fmExp m v-  I.UnreducedLevel v -> fmExp m v+fmLevel m (I.Plus _ l) = fmExp m l  -- --------------------------------------------- @@ -473,7 +468,7 @@               -- 0 is arbitrary, sort not read by Agda when reifying  instance Conversion MOT (Exp O) I.Term where-  convert e = case e of+  convert = \case     App _ _ (Var v) as -> frommyExps 0 as (I.Var v [])     App _ _ (Const c) as -> do       cdef <- lift $ readIORef c@@ -485,7 +480,7 @@         frommyExps n as v -}           (ndrop, h) = case iscon of-                         Just (n,fs) -> (n, \ q -> I.Con (I.ConHead q Cm.Inductive fs) Cm.ConOSystem)+                         Just (n,fs) -> (n, \ q -> I.Con (I.ConHead q I.IsData Cm.Inductive fs) Cm.ConOSystem)                          Nothing -> (0, \ f vs -> I.Def f vs)       frommyExps ndrop as (h name [])     Lam hid t -> I.Lam (icnvh hid) <$> convert t@@ -641,7 +636,7 @@         cdef <- lift $ readIORef c         let (Just (ndrop,_), name) = cdorigin cdef         ps' <- cnvps ndrop ps-        let con = I.ConHead name Cm.Inductive [] -- TODO: restore record fields!+        let con = I.ConHead name I.IsData Cm.Inductive [] -- TODO: restore DataOrRecord and record fields!         return (I.ConP con I.noConPatternInfo ps')        CSPatExp e -> do         e' <- convert e {- renm e -} -- renaming before adding to clause below@@ -662,6 +657,7 @@    , I.clauseBody  = body    , I.clauseType  = Nothing -- TODO: compute clause type    , I.clauseCatchall = False+   , I.clauseExact       = Nothing -- TODO    , I.clauseRecursive   = Nothing -- TODO: Don't know here whether recursive or not !?    , I.clauseUnreachable = Nothing -- TODO: Don't know here whether reachable or not !?    , I.clauseEllipsis = Cm.NoEllipsis

src/full/Agda/Auto/NarrowingSearch.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.Auto.NarrowingSearch where @@ -12,13 +11,18 @@ newtype Prio = Prio { getPrio :: Int }  deriving (Eq, Ord, Num) -class Trav a blk | a -> blk where-  trav :: Monad m => (forall b . Trav b blk => MM b blk -> m ()) -> a -> m ()+class Trav a where+  type Block a+  trav :: Monad m => (forall b. TravWith b (Block a) => MM b (Block b) -> m ()) -> a -> m () -instance Trav a blk => Trav (MM a blk) blk where+-- | Trav instance 'a' with block type 'blk'+type TravWith a blk = (Trav a, Block a ~ blk)++instance TravWith a blk => Trav (MM a blk) where+  type Block (MM a blk) = blk   trav f me = f me -data Term blk = forall a . Trav a blk => Term a+data Term blk = forall a. TravWith a blk => Term a  -- | Result of type-checking. data Prop blk@@ -240,9 +244,7 @@  NotM x -> f x  Meta m -> do   bind <- readIORef $ mbind m-  case bind of-   Just x -> f x-   Nothing -> fm+  maybe fm f bind  mmpcase :: Refinable a blk => BlkInfo blk -> MM a blk -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk) mmpcase blkinfo x f = case x of@@ -283,8 +285,7 @@  waitok :: OKHandle blk -> MetaEnv (MB b blk) -> MetaEnv (MB b blk) waitok okh f =- mmcase okh $ \b -> case b of -- principle constraint is never present for okhandle so it will not be refined-  OKVal -> f+ mmcase okh $ \ OKVal -> f -- principle constraint is never present for okhandle so it will not be refined  mbret :: a -> MetaEnv (MB a blk) mbret x = return $ NotB x@@ -413,10 +414,11 @@          ) mcomptr         obs <- ureadIORef (mobs m)         res <- recalcs obs-        case res of-         True -> -- failed-          return $ Left False-         False -> lift $ search depthleft -- succeeded+        if res+          then+            return $ Left False     -- failed+          else+            lift $ search depthleft -- succeeded      doit = do      res <- search depth@@ -448,14 +450,15 @@   runUndo $ do   res <- reccalc p (Just mainroot)-  case res of-   True -> -- failed immediately-    return False-   False -> do-    Left _solFound <- lift $ searchSubProb [(mainroot, Nothing)] searchdepth-    dr <- lift $ readIORef depthreached-    return dr+  if res -- failed immediately+    then+        return False+    else+      do+        Left _solFound <- lift $ searchSubProb [(mainroot, Nothing)] searchdepth+        lift $ readIORef depthreached + extractblkinfos :: Metavar a blk -> IO [blk] extractblkinfos m = do  obs <- readIORef $ mobs m@@ -469,8 +472,7 @@   f ((QPDoubleBlocked{}, _) : cs) = f cs  recalcs :: [(QPB a blk, Maybe (CTree blk))] -> Undo Bool-recalcs [] = return False-recalcs (c : cs) = seqc (recalc c) (recalcs cs)+recalcs cs = foldr (seqc . recalc) (return False) cs  seqc :: Undo Bool -> Undo Bool -> Undo Bool seqc x y = do@@ -480,33 +482,33 @@   False -> y  recalc :: (QPB a blk, Maybe (CTree blk)) -> Undo Bool-recalc (con, node) =- case con of-  QPBlocked _ cont -> reccalc cont node+recalc (con, node) = case con of+  QPBlocked       _    cont -> reccalc cont node   QPDoubleBlocked flag cont -> do-   fl <- ureadIORef flag-   if fl then-     return False-    else do-     uwriteIORef flag True-     reccalc cont node+    fl <- ureadIORef flag+    if fl+      then return False+      else do+        uwriteIORef flag True+        reccalc cont node  reccalc :: MetaEnv (PB blk) -> Maybe (CTree blk) -> Undo Bool reccalc cont node = do- res <- calc cont node- case res of-  Nothing -> return True-  Just pendhandles ->-   foldM (\res1 h ->-    case res1 of-     True -> return res1-     False -> do---      uwriteIORef (mbind h) $ Just OKVal-      obs <- ureadIORef (mobs h)-      recalcs obs-   ) False pendhandles+  res <- calc cont node+  case res of+    Nothing -> return True+    Just pendhandles ->+      foldM+        ( \res1 h ->+            if res1+              then return res1+              else do+                uwriteIORef (mbind h) $ Just OKVal+                obs <- ureadIORef (mobs h)+                recalcs obs+        )+        False+        pendhandles  calc :: forall blk . MetaEnv (PB blk) -> Maybe (CTree blk) -> Undo (Maybe [OKMeta blk]) calc cont node = do@@ -558,7 +560,10 @@        storeprio node (NoPrio False) []     PDoubleBlocked m1 m2 cont -> do      flag <- lift $ newIORef False-     let newobs = ((QPDoubleBlocked flag cont, node) :)++     let newobs :: forall b. [(QPB b blk, Maybe (CTree blk))]+                          -> [(QPB b blk, Maybe (CTree blk))]+         newobs = ((QPDoubleBlocked flag cont, node) :)      umodifyIORef (mobs m1) newobs      umodifyIORef (mobs m2) newobs      storeprio node (NoPrio False) []@@ -610,32 +615,37 @@     ConnectHandle (NotM _) _ -> __IMPOSSIBLE__  choosePrioMeta :: Bool -> PrioMeta blk -> PrioMeta blk -> PrioMeta blk-choosePrioMeta flip pm1@(PrioMeta p1 _) pm2@(PrioMeta p2 _) = if p1 > p2 then pm1 else if p2 > p1 then pm2 else if flip then pm2 else pm1+choosePrioMeta flip pm1@(PrioMeta p1 _) pm2@(PrioMeta p2 _)+  | p1 > p2 = pm1+  | p2 > p1 = pm2+  | flip = pm2+  | otherwise = pm1 choosePrioMeta _ pm@(PrioMeta _ _) (NoPrio _) = pm choosePrioMeta _ (NoPrio _) pm@(PrioMeta _ _) = pm choosePrioMeta _ (NoPrio d1) (NoPrio d2) = NoPrio (d1 && d2)  propagatePrio :: CTree blk -> Undo [OKMeta blk] propagatePrio node = do- parent <- lift $ readIORef $ ctparent node- case parent of-  Nothing -> return []-  Just parent -> do-   Just sc <- ureadIORef (ctsub parent)-   pm1 <- ureadIORef $ ctpriometa $ scsub1 sc-   pm2 <- ureadIORef $ ctpriometa $ scsub2 sc-   flip <- ureadIORef $ scflip sc-   let pm = choosePrioMeta flip pm1 pm2-   opm <- ureadIORef (ctpriometa parent)-   if (not (pm == opm)) then do-     uwriteIORef (ctpriometa parent) pm-     phs <- case pm of-      NoPrio True -> ureadIORef (cthandles parent)-      _ -> return []-     phs2 <- propagatePrio parent-     return $ phs ++ phs2-    else-     return []+  parent <- lift $ readIORef $ ctparent node+  case parent of+    Nothing     -> return []+    Just parent -> do+      Just sc <- ureadIORef (ctsub parent)+      pm1     <- ureadIORef $ ctpriometa $ scsub1 sc+      pm2     <- ureadIORef $ ctpriometa $ scsub2 sc+      flip    <- ureadIORef $ scflip sc+      let pm = choosePrioMeta flip pm1 pm2+      opm <- ureadIORef (ctpriometa parent)+      if (pm /= opm)+        then do+          uwriteIORef (ctpriometa parent) pm+          phs <- case pm of+            NoPrio True -> ureadIORef (cthandles parent)+            _           -> return []+          phs2 <- propagatePrio parent+          return $ phs ++ phs2+        else+          return []  data Choice = LeftDisjunct | RightDisjunct

src/full/Agda/Auto/Options.hs view

@@ -86,7 +86,7 @@ parseTime [] = 0 parseTime xs = read ds * modifier + parseTime r where   (ds , modr) = span isDigit xs-  (mod , r)   = span (not . isDigit) modr+  (mod , r)   = break isDigit modr    modifier = case mod of     "ms" -> 1

src/full/Agda/Auto/SearchControl.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.Auto.SearchControl where@@ -69,7 +68,7 @@   step eri RINotConstructor         = eri { eriIsEliminand = True }   step eri (RIUsedVars nuids nused) = eri { eriUsedVars = Just (nuids, nused) }   step eri (RIIotaStep semif)       = eri { eriIotaStep = Just iota' } where-    iota' = semif || fromMaybe False (eriIotaStep eri)+    iota' = semif || (Just True ==) (eriIotaStep eri)   step eri RIPickSubsvar            = eri { eriPickSubsVar = True }   step eri (RIEqRState s)           = eri { eriEqRState = Just s }   step eri _ = __IMPOSSIBLE__@@ -207,10 +206,10 @@    ExpRefInfo { eriMain  = Just (RIMainInfo n tt iotastepdone)               , eriUnifs = unis               , eriInfTypeUnknown = inftypeunknown-              , eriIsEliminand = iseliminand+              , eriIsEliminand = iseliminand -- TODO:: Defined but not used               , eriUsedVars = Just (uids, usedvars)               , eriIotaStep = iotastep-              , eriPickSubsVar = picksubsvar+              , eriPickSubsVar = picksubsvar -- TODO:: Defined but not used               , eriEqRState = meqrstate               } = getinfo infos @@ -230,9 +229,9 @@       adjustCost i = if inftypeunknown then costInferredTypeUnkown else i      varcost v | v < n - deffreevars = adjustCost $-       if elem v (mapMaybe getVar usedvars)+       if v `elem` (mapMaybe getVar usedvars)        then costAppVarUsed else costAppVar-     varcost v | otherwise = adjustCost costAppHint+     varcost v | otherwise           = adjustCost costAppHint      varapps  = map (\ v -> Move (varcost v) $ app n meta Nothing (Var v)) [0..n - 1]      hintapps = map (\(c, hm) -> Move (cost c hm) (app n meta Nothing (Const c))) hints        where@@ -240,10 +239,10 @@          cost c hm = adjustCost $ case (iotastep , hm) of            (Just _  , _       ) -> costIotaStep            (Nothing , HMNormal) ->-             if elem c (mapMaybe getConst usedvars)+             if c `elem` (mapMaybe getConst usedvars)              then costAppHintUsed else costAppHint            (Nothing , HMRecCall) ->-             if elem c (mapMaybe getConst usedvars)+             if c `elem` (mapMaybe getConst usedvars)              then costAppRecCallUsed else costAppRecCall      generics = varapps ++ hintapps     in case rawValue tt of@@ -252,8 +251,8 @@       return [eq_end, eq_step]       HNPi hid _ _ (Abs id _) -> return $-         (Move (adjustCost (if iotastepdone then costLamUnfold else costLam)) $ newLam hid id)-       : (Move costAbsurdLam $ return $ AbsurdLambda hid)+         Move (adjustCost (if iotastepdone then costLamUnfold else costLam)) (newLam hid id)+       : Move costAbsurdLam (return $ AbsurdLambda hid)        : generics       HNSort (Set l) -> return $@@ -300,12 +299,11 @@        in uni ++ generics       HNApp (Const c) _ ->        let (uid, isunique) = pickUid uids $ seenUIds hne-       in (Move (costUnificationIf isunique) $ app n meta uid (Const c)) : generics+       in Move (costUnificationIf isunique) (app n meta uid (Const c)) : generics       HNLam{} -> generics       HNPi hid possdep _ _ ->        let (uid, isunique) = pickUid uids $ seenUIds hne-       in (Move (costUnificationIf isunique)-          $ newPi (fromMaybe meta uid) possdep hid) : generics+       in Move (costUnificationIf isunique) (newPi (fromMaybe meta uid) possdep hid) : generics       HNSort (Set l) -> map (Move costUnification . set) [0..l] ++ generics       HNSort _ -> generics    _ -> __IMPOSSIBLE__@@ -413,25 +411,30 @@  -- --------------------------------- -instance Trav a blk => Trav [a] blk where+instance Trav a => Trav [a] where+  type Block [a] = Block a   trav _ []     = return ()   trav f (x:xs) = trav f x >> trav f xs -instance Trav (MId, CExp o) (RefInfo o) where+instance Trav (MId, CExp o) where+  type Block (MId, CExp o) = RefInfo o   trav f (_, ce) = trav f ce -instance Trav (TrBr a o) (RefInfo o) where+instance Trav (TrBr a o) where+  type Block (TrBr a o) = RefInfo o   trav f (TrBr es _) = trav f es -instance Trav (Exp o) (RefInfo o) where-  trav f e = case e of-    App _ _ _ args          -> trav f args+instance Trav (Exp o) where+  type Block (Exp o) = RefInfo o+  trav f = \case+    App _ _ _ args         -> trav f args     Lam _ (Abs _ b)        -> trav f b     Pi _ _ _ it (Abs _ ot) -> trav f it >> trav f ot     Sort _                 -> return ()     AbsurdLambda{}         -> return () -instance Trav (ArgList o) (RefInfo o) where+instance Trav (ArgList o) where+  type Block (ArgList o) = RefInfo o   trav _ ALNil               = return ()   trav f (ALCons _ arg args) = trav f arg >> trav f args   trav f (ALProj eas _ _ as) = trav f eas >> trav f as

src/full/Agda/Auto/Syntax.hs view

@@ -268,7 +268,7 @@   metaliseOKH :: t -> IO t  instance MetaliseOKH t => MetaliseOKH (MM t a) where-  metaliseOKH e = case e of+  metaliseOKH = \case     Meta m -> return $ Meta m     NotM e -> NotM <$> metaliseOKH e @@ -276,17 +276,17 @@   metaliseOKH (Abs id b) = Abs id <$> metaliseOKH b  instance MetaliseOKH (Exp o) where-  metaliseOKH e = case e of+  metaliseOKH = \case     App uid okh elr args ->       (\ m -> App uid m elr) <$> (Meta <$> initMeta) <*> metaliseOKH args     Lam hid b -> Lam hid <$> metaliseOKH b     Pi uid hid dep it ot ->       Pi uid hid dep <$> metaliseOKH it <*> metaliseOKH ot-    Sort{} -> return e-    AbsurdLambda{} -> return e+    e@Sort{} -> return e+    e@AbsurdLambda{} -> return e  instance MetaliseOKH (ArgList o) where-  metaliseOKH e = case e of+  metaliseOKH = \case     ALNil -> return ALNil     ALCons hid a as -> ALCons hid <$> metaliseOKH a <*> metaliseOKH as     ALProj eas idx hid as ->@@ -302,7 +302,7 @@   expandMetas :: t -> IO t  instance ExpandMetas t => ExpandMetas (MM t a) where-  expandMetas t = case t of+  expandMetas = \case     NotM e -> NotM <$> expandMetas e     Meta m -> do       mb <- readIORef (mbind m)@@ -314,16 +314,16 @@   expandMetas (Abs id b) = Abs id <$> expandMetas b  instance ExpandMetas (Exp o) where-  expandMetas t = case t of+  expandMetas = \case     App uid okh elr args -> App uid okh elr <$> expandMetas args     Lam hid b -> Lam hid <$> expandMetas b     Pi uid hid dep it ot ->       Pi uid hid dep <$> expandMetas it <*> expandMetas ot-    Sort{} -> return t-    AbsurdLambda{} -> return t+    t@Sort{} -> return t+    t@AbsurdLambda{} -> return t  instance ExpandMetas (ArgList o) where-  expandMetas e = case e of+  expandMetas = \case     ALNil -> return ALNil     ALCons hid a as -> ALCons hid <$> expandMetas a <*> expandMetas as     ALProj eas idx hid as ->@@ -369,7 +369,7 @@   weak' n (Clos as x) = Clos (Weak n : as) x  instance Weakening (ICArgList o) where-  weak' n e = case e of+  weak' n = \case     CALNil         -> CALNil     CALConcat a as -> CALConcat (weak' n a) (weak' n as) @@ -407,12 +407,12 @@   freeVarsOffset n (Abs id e) = freeVarsOffset (n + 1) e  instance FreeVars (Elr o) where-  freeVarsOffset n e = case e of+  freeVarsOffset n = \case     Var v   -> Set.singleton (v - n)     Const{} -> Set.empty  instance FreeVars (Exp o) where-  freeVarsOffset n e = case e of+  freeVarsOffset n = \case    App _ _ elr args -> freeVarsOffset n (elr, args)    Lam _ b          -> freeVarsOffset n b    Pi _ _ _ it ot   -> freeVarsOffset n (it, ot)@@ -444,20 +444,20 @@   renameOffset j ren (Abs id e) = Abs id $ renameOffset (j + 1) ren e  instance Renaming (Elr o) where-  renameOffset j ren e = case e of+  renameOffset j ren = \case     Var v | v >= j -> Var (ren (v - j) + j)-    _              -> e+    e              -> e  instance Renaming (Exp o) where-  renameOffset j ren e = case e of+  renameOffset j ren = \case     App uid ok elr args -> uncurry (App uid ok) $ renameOffset j ren (elr, args)     Lam hid e -> Lam hid (renameOffset j ren e)     Pi a b c it ot -> uncurry (Pi a b c) $ renameOffset j ren (it, ot)-    Sort{}         -> e-    AbsurdLambda{} -> e+    e@Sort{}         -> e+    e@AbsurdLambda{} -> e  instance Renaming (ArgList o) where-  renameOffset j ren e = case e of+  renameOffset j ren = \case     ALNil           -> ALNil     ALCons hid a as -> uncurry (ALCons hid) $ renameOffset j ren (a, as)     ALConPar as     -> ALConPar (renameOffset j ren as)

src/full/Agda/Auto/Typecheck.hs view

@@ -2,7 +2,6 @@ module Agda.Auto.Typecheck where  import Data.IORef-import Control.Monad (liftM)  import Agda.Syntax.Common (Hiding (..)) import Agda.Auto.NarrowingSearch@@ -152,8 +151,8 @@   mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp) $ \hnityp -> case rawValue hnityp of    HNPi hid2 possdep it (Abs _ ot)      | ndfv > 0 || copyarg a || hid == hid2 -> mpret $-    And (Just ((if possdep then [Term a] else []) ++ [Term ctx, Term ityptrs]))-        (if ndfv > 0 then mpret OK else (tcExp (isdep || possdep) ctx (t it) a))+    And (Just ([Term a | possdep] ++ [Term ctx, Term ityptrs]))+        (if ndfv > 0 then mpret OK else tcExp (isdep || possdep) ctx (t it) a)         (tcargs (ndfv - 1) isdep ctx (sub a (t ot)) as (addend hid a elimtrm) isconstructor cont)    _ -> mpret $ Error "tcargs, inf type should be fun or pi (and same hid)" @@ -465,7 +464,7 @@     fhn semifok mexpmeta hne cont =      mmbpcase (iotastep True hne)       (\m -> do-        sf <- return False {- semiflex hne -}+        let sf = False {- semiflex hne -}         if semifok && sf then           cont (CMFlex m (CMFSemi mexpmeta hne))          else@@ -616,7 +615,7 @@        _ -> return False      boringClos :: [CAction o] -> EE Bool-    boringClos cl = liftM (all id) $ mapM f cl+    boringClos cl = and <$> mapM f cl      where f (Sub e) = boringExp e            f Skip = return True            f (Weak _) = return True@@ -702,7 +701,7 @@ iotapossmeta ce@(Clos cl _) cargs = do  xs <- mapM ncaction cl  y <- nccargs cargs- return $ not (all id xs && y)+ return $ not (and xs && y)  where   ncaction (Sub ce) = nonconstructor ce   ncaction Skip = return True

src/full/Agda/Benchmarking.hs view

@@ -4,10 +4,13 @@  module Agda.Benchmarking where +import Control.DeepSeq import qualified Control.Exception as E  import Data.IORef +import GHC.Generics (Generic)+ import System.IO.Unsafe  import Agda.Syntax.Concrete.Name (TopLevelModuleName)@@ -94,13 +97,15 @@     -- ^ Pretty printing names.   | TopModule TopLevelModuleName   | Definition QName-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic)  instance Pretty Phase where   pretty (TopModule m)  = pretty m   pretty (Definition q) = pretty q   pretty a = text (show a) +instance NFData Phase+ type Benchmark = B.Benchmark Phase type Account   = B.Account Phase @@ -126,7 +131,8 @@ benchmarks :: IORef Benchmark benchmarks = unsafePerformIO $ newIORef empty -instance MonadBench Phase IO where+instance MonadBench IO where+  type BenchPhase IO = Phase   getBenchmark = readIORef benchmarks   putBenchmark = writeIORef benchmarks   finally = E.finally

src/full/Agda/Compiler/Backend.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-} + -- | Interface for compiler backend writers. module Agda.Compiler.Backend   ( Backend(..), Backend'(..), Recompile(..), IsMain(..)@@ -9,6 +9,7 @@   , toTreeless   , module Agda.Syntax.Treeless   , module Agda.TypeChecking.Monad+  , module CheckResult   , activeBackendMayEraseType     -- For Agda.Main   , backendInteraction@@ -20,6 +21,7 @@   , activeBackend   ) where +import Control.DeepSeq import Control.Monad.State import Control.Monad.Trans.Maybe @@ -29,9 +31,12 @@ import Data.Map (Map) import qualified Data.Map as Map +import GHC.Generics (Generic)+ import System.Console.GetOpt  import Agda.Syntax.Treeless+import Agda.TypeChecking.Errors (getAllWarnings) -- Agda.TypeChecking.Monad.Base imports us, relying on the .hs-boot file to -- resolve the circular dependency. Fine. However, ghci loads the module after -- compilation, so it brings in all of the symbols. That causes .Base to see@@ -44,7 +49,7 @@  import Agda.Interaction.Options import Agda.Interaction.FindFile-import Agda.Interaction.Imports (getAllWarnings)+import Agda.Interaction.Imports as CheckResult (CheckResult(CheckResult), crInterface, crWarnings, crMode) import Agda.TypeChecking.Warnings  import Agda.Utils.FileName@@ -61,7 +66,7 @@ -- Public interface -------------------------------------------------------  data Backend where-  Backend :: Backend' opts env menv mod def -> Backend+  Backend :: NFData opts => Backend' opts env menv mod def -> Backend  data Backend' opts env menv mod def = Backend'   { backendName      :: String@@ -80,11 +85,11 @@   , postCompile      :: env -> IsMain -> Map ModuleName mod -> TCM ()       -- ^ Called after module compilation has completed. The @IsMain@ argument       --   is @NotMain@ if the @--no-main@ flag is present.-  , preModule        :: env -> IsMain -> ModuleName -> FilePath -> TCM (Recompile menv mod)+  , preModule        :: env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)       -- ^ Called before compilation of each module. Gets the path to the       --   @.agdai@ file to allow up-to-date checking of previously written       --   compilation results. Should return @Skip m@ if compilation is not-      --   required.+      --   required. Will be @Nothing@ if only scope checking.   , postModule       :: env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod       -- ^ Called after all definitions of a module have been compiled.   , compileDef       :: env -> menv -> IsMain -> Definition -> TCM def@@ -97,14 +102,15 @@       --   The answer should be 'False' if the compilation of the type       --   is used by a third party, e.g. in a FFI binding.   }+  deriving Generic  data Recompile menv mod = Recompile menv | Skip mod  -- | Call the 'compilerMain' function of the given backend. -callBackend :: String -> IsMain -> Interface -> TCM ()-callBackend name iMain i = lookupBackend name >>= \case-  Just (Backend b) -> compilerMain b iMain i+callBackend :: String -> IsMain -> CheckResult -> TCM ()+callBackend name iMain checkResult = lookupBackend name >>= \case+  Just (Backend b) -> compilerMain b iMain checkResult   Nothing -> do     backends <- useTC stBackends     genericError $@@ -119,7 +125,7 @@ --   to the user.  otherBackends :: [String]-otherBackends = ["GHCNoMain", "LaTeX", "QuickLaTeX"]+otherBackends = ["GHCNoMain", "QuickLaTeX"]  -- | Look for a backend of the given name. @@ -142,10 +148,30 @@   Backend b <- fromMaybe __IMPOSSIBLE__ <$> activeBackend   mayEraseType b q +instance NFData Backend where+  rnf (Backend b) = rnf b++instance NFData opts => NFData (Backend' opts env menv mod def) where+  rnf (Backend' a b c d e f g h i j k l) =+    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+    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+ -- Internals --------------------------------------------------------------  data BackendWithOpts opts where-  BackendWithOpts :: Backend' opts env menv mod def -> BackendWithOpts opts+  BackendWithOpts ::+    NFData opts =>+    Backend' opts env menv mod def ->+    BackendWithOpts opts  backendWithOpts :: Backend -> Some BackendWithOpts backendWithOpts (Backend backend) = Some (BackendWithOpts backend)@@ -178,16 +204,10 @@       opts <- checkOpts opts       return (forgetAll forgetOpts backends, opts) -backendInteraction :: [Backend] -> (TCM (Maybe Interface) -> TCM ()) -> TCM (Maybe Interface) -> TCM ()-backendInteraction [] fallback check = fallback check-backendInteraction backends _ check = do-  opts   <- commandLineOptions-  let backendNames = [ backendName b | Backend b <- backends ]-      err flag = genericError $ "Cannot mix --" ++ flag ++ " and backends (" ++ List.intercalate ", " backendNames ++ ")"-  when (optInteractive     opts) $ err "interactive"-  when (optGHCiInteraction opts) $ err "interaction"-  when (optJSONInteraction opts) $ err "interaction-json"-  mi     <- check+backendInteraction :: AbsolutePath -> [Backend] -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()+backendInteraction mainFile backends setup check = do+  setup+  checkResult <- check mainFile    -- reset warnings   stTCWarnings `setTCLens` []@@ -195,24 +215,33 @@   noMain <- optCompileNoMain <$> pragmaOptions   let isMain | noMain    = NotMain              | otherwise = IsMain-  case mi of-    Nothing -> genericError $ "You can only compile modules without unsolved metavariables."-    Just i  -> sequence_ [ compilerMain backend isMain i | Backend backend <- backends ] +  unlessM (optAllowUnsolved <$> pragmaOptions) $ do+    let ws = crWarnings checkResult+        mode = crMode checkResult+    -- Possible warnings, but only scope checking: ok.+    -- (Compatibility with scope checking done during options validation).+    unless (mode == ModuleScopeChecked || null ws) $+      genericError $ "You can only compile modules without unsolved metavariables."++  sequence_ [ compilerMain backend isMain checkResult | Backend backend <- backends ]+   -- print warnings that might have accumulated during compilation   ws <- filter (not . isUnsolvedWarning . tcWarning) <$> getAllWarnings AllWarnings   unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws  -compilerMain :: Backend' opts env menv mod def -> IsMain -> Interface -> TCM ()-compilerMain backend isMain0 i = inCompilerEnv i $ do+compilerMain :: Backend' opts env menv mod def -> IsMain -> CheckResult -> TCM ()+compilerMain backend isMain0 checkResult = inCompilerEnv checkResult $ do   locallyTC eActiveBackendName (const $ Just $ backendName backend) $ do-    onlyScoping <- optOnlyScopeChecking <$> commandLineOptions-    when (not (scopeCheckingSuffices backend) && onlyScoping) $+    -- BEWARE: Do not use @optOnlyScopeChecking@ here; it does not authoritatively describe the type-checking mode!+    -- InteractionTop currently may invoke type-checking with scope checking regardless of that flag.+    when (not (scopeCheckingSuffices backend) && crMode checkResult == ModuleScopeChecked) $       genericError $         "The --only-scope-checking flag cannot be combined with " ++         backendName backend ++ "." +    let i = crInterface checkResult     -- Andreas, 2017-08-23, issue #2714     -- If the backend is invoked from Emacs, we can only get the --no-main     -- pragma option now, coming from the interface file.@@ -221,15 +250,25 @@       {-else-} (return isMain0)      env  <- preCompile backend (options backend)-    mods <- doCompile isMain i $ \ isMain i -> Map.singleton (iModuleName i) <$> compileModule backend env isMain i+    mods <- doCompile+        -- This inner function is called for both `Agda.Primitive` and the module in question,+        -- and all (distinct) imported modules. So avoid shadowing "isMain" or "i".+        (\ifaceIsMain iface -> Map.singleton (iModuleName iface) <$> compileModule backend env ifaceIsMain iface)+        isMain i+    -- Note that `doCompile` calls `setInterface` for each distinct module in the graph prior to calling into+    -- `compileModule`. This last one is just to ensure it's reset to _this_ module.     setInterface i     postCompile backend env isMain mods  compileModule :: Backend' opts env menv mod def -> env -> IsMain -> Interface -> TCM mod compileModule backend env isMain i = do   mName <- toTopLevelModuleName <$> curMName-  ifile <- maybe __IMPOSSIBLE__ (filePath . intFilePath) <$> findInterfaceFile mName-  r     <- preModule backend env isMain (iModuleName i) ifile+  -- The interface file will only exist if performing af full type-check, vs scoping.+  -- FIXME: Expecting backends to read the timestamp of the output path of the interface+  --        file for dirtiness checking is very roundabout and heavily couples backend+  --        implementations to the filesystem as the source of cache state.+  mifile <- (Just . filePath . intFilePath =<<) <$> findInterfaceFile mName+  r      <- preModule backend env isMain (iModuleName i) mifile   case r of     Skip m         -> return m     Recompile menv -> do

src/full/Agda/Compiler/Backend.hs-boot view

@@ -7,6 +7,8 @@   )   where +import Control.DeepSeq+ -- Explicitly adding the Agda.Syntax.Treeless import to the .hs-boot file -- so that the `Args` symbol can be hidden by the `SOURCE` import in -- TypeChecking.Monad.Base.@@ -24,6 +26,8 @@ import {-# SOURCE #-} Agda.TypeChecking.Monad.Base (TCM, BackendName)  data Backend++instance NFData Backend  activeBackendMayEraseType :: QName -> TCM Bool lookupBackend :: BackendName -> TCM (Maybe Backend)

+ src/full/Agda/Compiler/Builtin.hs view

@@ -0,0 +1,22 @@+{-|+  Built-in backends.+-}++module Agda.Compiler.Builtin where++import Agda.Compiler.Backend (Backend)++import Agda.Compiler.MAlonzo.Compiler (ghcBackend)+import Agda.Compiler.JS.Compiler (jsBackend)+import Agda.Interaction.Highlighting.Dot (dotBackend)+import Agda.Interaction.Highlighting.HTML (htmlBackend)+import Agda.Interaction.Highlighting.LaTeX (latexBackend)++builtinBackends :: [Backend]+builtinBackends =+  [ ghcBackend+  , jsBackend+  , dotBackend+  , htmlBackend+  , latexBackend+  ]

+ src/full/Agda/Compiler/Builtin.hs-boot view

@@ -0,0 +1,5 @@+module Agda.Compiler.Builtin where++import {-# SOURCE #-} Agda.Compiler.Backend++builtinBackends :: [Backend]

src/full/Agda/Compiler/CallCompiler.hs view

@@ -8,7 +8,6 @@ import qualified Control.Exception as E import Control.Monad.Trans -import Data.List ( intercalate ) import System.Exit import System.IO import System.Process@@ -41,7 +40,7 @@       Nothing     -> return ()       Just errors -> typeError (CompilationError errors)   else-    reportSLn "compile.cmd" 1 $ "NOT calling: " ++ intercalate " " (cmd : args)+    reportSLn "compile.cmd" 1 $ "NOT calling: " ++ unwords (cmd : args)  -- | Generalisation of @callCompiler@ where the raised exception is -- returned.@@ -52,7 +51,7 @@      -- ^ Command-line arguments.   -> TCM (Maybe String) callCompiler' cmd args = do-  reportSLn "compile.cmd" 1 $ "Calling: " ++ intercalate " " (cmd : args)+  reportSLn "compile.cmd" 1 $ "Calling: " ++ unwords (cmd : args)   (_, out, err, p) <-     liftIO $ createProcess                (proc cmd args) { std_err = CreatePipe

src/full/Agda/Compiler/Common.hs view

@@ -14,13 +14,14 @@ #endif  import Control.Monad-import Control.Monad.State  hiding (mapM_, forM_, mapM, forM, sequence)+import Control.Monad.State  import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Internal as I -import Agda.Interaction.FindFile+import Agda.Interaction.FindFile ( srcFilePath ) import Agda.Interaction.Options+import Agda.Interaction.Imports ( CheckResult, crInterface, crSource, Source(..) )  import Agda.TypeChecking.Monad @@ -44,57 +45,51 @@   mempty = IsMain   mappend = (<>) -doCompile :: forall r. Monoid r => IsMain -> Interface -> (IsMain -> Interface -> TCM r) -> TCM r-doCompile isMain i f = do+doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r+doCompile f isMain i = do   -- The Agda.Primitive module is implicitly assumed to be always imported,   -- even though it not necesseraly occurs in iImportedModules.   -- TODO: there should be a better way to get hold of Agda.Primitive?   [agdaPrimInter] <- filter (("Agda.Primitive"==) . prettyShow . iModuleName)     . map miInterface . Map.elems       <$> getVisitedModules-  flip evalStateT Set.empty $ mappend <$> comp NotMain agdaPrimInter <*> comp isMain i-  where-    comp :: IsMain -> Interface -> StateT (Set ModuleName) TCM r-    comp isMain i = do-      alreadyDone <- Set.member (iModuleName i) <$> get-      if alreadyDone then return mempty else do-        imps <- lift $-          map miInterface . catMaybes <$>-            mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i)-        ri <- mconcat <$> mapM (comp NotMain) imps-        lift $ setInterface i-        r <- lift $ f isMain i-        modify (Set.insert $ iModuleName i)-        return $ mappend ri r+  flip evalStateT Set.empty $ mappend <$> doCompile' f NotMain agdaPrimInter <*> doCompile' f isMain i +-- This helper function is called for both `Agda.Primitive` and the module in question.+-- It's also called for each imported module, recursively. (Avoiding duplicates).+doCompile'+  :: Monoid r+  => (IsMain -> Interface -> TCM r) -> (IsMain -> Interface -> StateT (Set ModuleName) TCM r)+doCompile' f isMain i = do+  alreadyDone <- gets (Set.member (iModuleName i))+  if alreadyDone then return mempty else do+    imps <- lift $+      map miInterface . catMaybes <$>+        mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i)+    ri <- mconcat <$> mapM (doCompile' f NotMain) imps+    lift $ setInterface i+    r <- lift $ f isMain i+    modify (Set.insert $ iModuleName i)+    return $ mappend ri r+ setInterface :: Interface -> TCM () setInterface i = do   opts <- getsTC (stPersistentOptions . stPersistentState)   setCommandLineOptions opts-  mapM_ setOptionsFromPragma (iPragmaOptions i)+  mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++ iFilePragmaOptions i)   stImportedModules `setTCLens` Set.fromList (map fst $ iImportedModules i)   stCurrentModule   `setTCLens` Just (iModuleName i) -curIF :: TCM Interface+curIF :: ReadTCState m => m Interface curIF = do-  mName <- useTC stCurrentModule-  case mName of-    Nothing   -> __IMPOSSIBLE__-    Just name -> do-      mm <- getVisitedModule (toTopLevelModuleName name)-      case mm of-        Nothing -> __IMPOSSIBLE__-        Just mi -> return $ miInterface mi---curSig :: TCM Signature-curSig = iSignature <$> curIF+  name <- curMName+  maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule (toTopLevelModuleName name) -curMName :: TCM ModuleName-curMName = sigMName <$> curSig+curMName :: ReadTCState m => m ModuleName+curMName = fromMaybe __IMPOSSIBLE__ <$> useTC stCurrentModule -curDefs :: TCM Definitions-curDefs = fmap (HMap.filter (not . defNoCompilation)) $ (^. sigDefinitions) <$> curSig+curDefs :: ReadTCState m => m Definitions+curDefs = HMap.filter (not . defNoCompilation) . (^. sigDefinitions) . iSignature <$> curIF  sortDefs :: Definitions -> [(QName, Definition)] sortDefs defs =@@ -104,18 +99,10 @@   List.sortBy (compare `on` fst) $   HMap.toList defs -sigMName :: Signature -> ModuleName-sigMName sig = case Map.keys (sig ^. sigSections) of-  []    -> __IMPOSSIBLE__-  m : _ -> m---compileDir :: TCM FilePath+compileDir :: HasOptions m => m FilePath compileDir = do   mdir <- optCompileDir <$> commandLineOptions-  case mdir of-    Just dir -> return dir-    Nothing  -> __IMPOSSIBLE__+  maybe __IMPOSSIBLE__ return mdir   repl :: [String] -> String -> String@@ -127,8 +114,11 @@   -- | Sets up the compilation environment.-inCompilerEnv :: Interface -> TCM a -> TCM a-inCompilerEnv mainI cont = do+inCompilerEnv :: CheckResult -> TCM a -> TCM a+inCompilerEnv checkResult cont = do+  let mainI = crInterface checkResult+      checkedSource = crSource checkResult+   -- Preserve the state (the compiler modifies the state).   -- Andreas, 2014-03-23 But we might want to collect Benchmark info,   -- so use localTCState.@@ -140,13 +130,13 @@     -- the current pragma options persistent when we setCommandLineOptions     -- below.     opts <- getsTC $ stPersistentOptions . stPersistentState-    compileDir <- case optCompileDir opts of-      Just dir -> return dir-      Nothing  -> do-        -- The default output directory is the project root.-        let tm = toTopLevelModuleName $ iModuleName mainI-        f <- srcFilePath <$> findFile tm-        return $ filePath $ C.projectRoot f tm+    let compileDir = case optCompileDir opts of+          Just dir -> dir+          Nothing  ->+            -- The default output directory is the project root.+            let tm = toTopLevelModuleName $ iModuleName mainI+                f  = srcFilePath $ srcOrigin checkedSource+            in filePath $ C.projectRoot f tm     setCommandLineOptions $       opts { optCompileDir = Just compileDir } @@ -154,7 +144,7 @@     -- 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.-    when (["--no-main"] `elem` iPragmaOptions mainI) $+    when (["--no-main"] `elem` iFilePragmaOptions mainI) $       stPragmaOptions `modifyTCLens` \ o -> o { optCompileNoMain = True }      setScope (iInsideScope mainI) -- so that compiler errors don't use overly qualified names@@ -164,7 +154,7 @@   stTCWarnings `setTCLens` newWarnings   return a -topLevelModuleName :: ModuleName -> TCM ModuleName+topLevelModuleName :: ReadTCState m => ModuleName -> m ModuleName topLevelModuleName m = do   -- get the names of the visited modules   visited <- List.map (iModuleName . miInterface) . Map.elems <$>

src/full/Agda/Compiler/JS/Compiler.hs view

@@ -1,26 +1,31 @@+-- | Main module for JS backend.  module Agda.Compiler.JS.Compiler where  import Prelude hiding ( null, writeFile ) -import Control.Monad.Reader ( liftIO )+import Control.DeepSeq import Control.Monad.Trans -import Data.Char ( isSpace )-import Data.List ( intercalate, partition )-import Data.Set ( Set, null, insert, difference, delete )-import Data.Traversable (traverse)-import Data.Map ( fromList )+import Data.Char     ( isSpace )+import Data.Foldable ( forM_ )+import Data.List     ( dropWhileEnd, findIndex, intercalate, partition )+import Data.Set      ( Set )+ import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Text as T -import System.Directory ( createDirectoryIfMissing )-import System.FilePath ( splitFileName, (</>) )+import GHC.Generics (Generic) +import System.Directory   ( createDirectoryIfMissing )+import System.Environment ( setEnv )+import System.FilePath    ( splitFileName, (</>) )+import System.Process     ( callCommand )+ import Paths_Agda  import Agda.Interaction.Options-import Agda.Interaction.Imports ( isNewerThan )  import Agda.Syntax.Common import Agda.Syntax.Concrete.Name ( isNoName )@@ -30,33 +35,44 @@ import Agda.Syntax.Internal   ( Name, Type   , arity, nameFixity, unDom )-import Agda.Syntax.Literal ( Literal(..) )+import Agda.Syntax.Literal       ( Literal(..) )+import Agda.Syntax.Treeless      ( ArgUsage(..), filterUsed ) import qualified Agda.Syntax.Treeless as T  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.Debug ( reportSLn ) import Agda.TypeChecking.Reduce ( instantiateFull )+import Agda.TypeChecking.Substitute as TC ( TelV(..), raise, subst ) import Agda.TypeChecking.Pretty -import Agda.Utils.Maybe-import Agda.Utils.Monad ( (<$>), (<*>), ifM )-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.FileName ( isNewerThan )+import Agda.Utils.Function ( iterate' )+import Agda.Utils.List ( downFrom, headWithDefault )+import Agda.Utils.List1 ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe ( boolToMaybe, catMaybes, caseMaybeM, fromMaybe, whenNothing )+import Agda.Utils.Monad ( ifM, when )+import Agda.Utils.Null  ( null )+import Agda.Utils.Pretty (prettyShow, render) import qualified Agda.Utils.Pretty as P import Agda.Utils.IO.Directory import Agda.Utils.IO.UTF8 ( writeFile )+import Agda.Utils.Singleton ( singleton )  import Agda.Compiler.Common 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 )+import Agda.Compiler.Treeless.Subst () import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..))  import Agda.Compiler.JS.Syntax-  ( Exp(Self,Local,Global,Undefined,String,Char,Integer,Double,Lambda,Object,Apply,Lookup,If,BinOp,PlainJS),-    LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId), Export(Export), Module(Module),-    modName, expName, uses )+  ( 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+  ) import Agda.Compiler.JS.Substitution   ( curriedLambda, curriedApply, emp, apply ) import qualified Agda.Compiler.JS.Pretty as JSPretty@@ -70,7 +86,7 @@ jsBackend :: Backend jsBackend = Backend jsBackend' -jsBackend' :: Backend' JSOptions JSOptions JSModuleEnv () (Maybe Export)+jsBackend' :: Backend' JSOptions JSOptions JSModuleEnv Module (Maybe Export) jsBackend' = Backend'   { backendName           = jsBackendName   , backendVersion        = Nothing@@ -94,59 +110,131 @@ --- Options ---  data JSOptions = JSOptions-  { optJSCompile :: Bool }+  { optJSCompile  :: Bool+  , optJSOptimize :: Bool+  , optJSMinify   :: Bool+      -- ^ Remove spaces etc. See https://en.wikipedia.org/wiki/Minification_(programming).+  , optJSVerify   :: Bool+      -- ^ Run generated code through interpreter.+  }+  deriving Generic +instance NFData JSOptions+ defaultJSOptions :: JSOptions defaultJSOptions = JSOptions-  { optJSCompile = False }+  { optJSCompile  = False+  , optJSOptimize = False+  , optJSMinify   = False+  , optJSVerify   = False+  }  jsCommandLineFlags :: [OptDescr (Flag JSOptions)] jsCommandLineFlags =     [ Option [] ["js"] (NoArg enable) "compile program using the JS backend"+    , Option [] ["js-optimize"] (NoArg enableOpt) "turn on optimizations during JS code generation"+    -- 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)"     ]   where-    enable o = pure o{ optJSCompile = True }+    enable       o = pure o{ optJSCompile  = True }+    enableOpt    o = pure o{ optJSOptimize = True }+    enableMin    o = pure o{ optJSMinify   = True }+    enableVerify o = pure o{ optJSVerify   = True }  --- Top-level compilation ---  jsPreCompile :: JSOptions -> TCM JSOptions jsPreCompile opts = return opts -jsPostCompile :: JSOptions -> IsMain -> a -> TCM ()-jsPostCompile _ _ _ = copyRTEModules+-- | After all modules have been compiled, copy RTE modules and verify compiled modules. +jsPostCompile :: JSOptions -> IsMain -> Map.Map ModuleName Module -> TCM ()+jsPostCompile opts _ ms = do++  -- Copy RTE modules.++  compDir  <- compileDir+  liftIO $ do+    dataDir <- getDataDir+    let srcDir = dataDir </> "JS"+    copyDirContent srcDir compDir++  -- Verify generated JS modules (except for main).++  reportSLn "compile.js.verify" 10 $ "Considering to verify generated JS modules"+  when (optJSVerify opts) $ do++    reportSLn "compile.js.verify" 10 $ "Verifying generated JS modules"+    liftIO $ setEnv "NODE_PATH" compDir++    forM_ ms $ \ Module{ modName, callMain } -> do+      jsFile <- outFile modName+      reportSLn "compile.js.verify" 30 $ unwords [ "Considering JS module:" , jsFile ]++      -- Since we do not run a JS program for real, we skip all modules that could+      -- have a call to main.+      -- Atm, modules whose compilation was skipped are also skipped during verification+      -- (they appear here as main modules).+      whenNothing callMain $ do+        let cmd = unwords [ "node", "-", "<", jsFile ]+        reportSLn "compile.js.verify" 20 $ unwords [ "calling:", cmd ]+        liftIO $ callCommand cmd+++mergeModules :: Map.Map ModuleName Module -> [(GlobalId, Export)]+mergeModules ms+    = [ (jsMod n, e)+      | (n, Module _ _ es _) <- Map.toList ms+      , e <- es+      ]+ --- Module compilation ---  type JSModuleEnv = Maybe CoinductionKit -jsPreModule :: JSOptions -> IsMain -> ModuleName -> FilePath -> TCM (Recompile JSModuleEnv ())-jsPreModule _ _ m ifile = ifM uptodate noComp yesComp+jsPreModule :: JSOptions -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module)+jsPreModule _opts _ m mifile = ifM uptodate noComp yesComp   where-    uptodate = liftIO =<< isNewerThan <$> outFile_ <*> pure ifile+    uptodate = case mifile of+      Nothing -> pure False+      Just ifile -> liftIO =<< isNewerThan <$> outFile_ <*> pure ifile+    ifileDesc = fromMaybe "(memory)" mifile      noComp = do       reportSLn "compile.js" 2 . (++ " : no compilation is needed.") . prettyShow =<< curMName-      return $ Skip ()+      return $ Skip skippedModule +    -- A skipped module acts as a fake main module, to be skipped by --js-verify as well.+    skippedModule = Module (jsMod m) mempty mempty (Just __IMPOSSIBLE__)+     yesComp = do       m   <- prettyShow <$> curMName       out <- outFile_-      reportSLn "compile.js" 1 $ repl [m, ifile, out] "Compiling <<0>> in <<1>> to <<2>>"+      reportSLn "compile.js" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"       Recompile <$> coinductionKit -jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM ()-jsPostModule _ _ isMain _ defs = do+jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM Module+jsPostModule opts _ isMain _ defs = do   m             <- jsMod <$> curMName   is            <- map (jsMod . fst) . iImportedModules <$> curIF-  let es = catMaybes defs-  writeModule $ Module m (reorder es) main+  let mod = Module m is (reorder es) callMain+  writeModule (optJSMinify opts) mod+  return mod   where-    main = case isMain of-      IsMain  -> Just $ Apply (Lookup Self $ MemberId "main") [Lambda 1 emp]-      NotMain -> Nothing+  es       = catMaybes defs+  main     = MemberId "main"+  -- Andreas, 2020-10-27, only add invocation of "main" if such function is defined.+  -- This allows loading of generated .js files into an interpreter+  -- even if they do not define "main".+  hasMain  = isMain == IsMain && any ((singleton main ==) . expName) es+  callMain :: Maybe Exp+  callMain = boolToMaybe hasMain $ Apply (Lookup Self main) [Lambda 1 emp] + jsCompileDef :: JSOptions -> JSModuleEnv -> IsMain -> Definition -> TCM (Maybe Export)-jsCompileDef _ kit _isMain def = definition kit (defName def, def)+jsCompileDef opts kit _isMain def = definition (opts, kit) (defName def, def)  -------------------------------------------------- -- Naming@@ -169,33 +257,40 @@   | isNoName n = MemberId ("_" ++ show (nameId n))   | otherwise  = MemberId $ prettyShow n --- Rather annoyingly, the anonymous construtor of a record R in module M--- is given the name M.recCon, but a named constructor C--- is given the name M.R.C, sigh. This causes a lot of hoop-jumping--- in the map from Agda names to JS names, which we patch by renaming--- anonymous constructors to M.R.record.--global' :: QName -> TCM (Exp,[MemberId])+global' :: QName -> TCM (Exp, JSQName) global' q = do   i <- iModuleName <$> curIF   modNm <- topLevelModuleName (qnameModule q)   let+    -- Global module prefix     qms = mnameToList $ qnameModule q-    nm = map jsMember (drop (length $ mnameToList modNm) qms ++ [qnameName q])+    -- File-local module prefix+    localms = drop (length $ mnameToList modNm) qms+    nm = fmap jsMember $ List1.snoc localms $ qnameName q   if modNm == i     then return (Self, nm)     else return (Global (jsMod modNm), nm) -global :: QName -> TCM (Exp,[MemberId])+global :: QName -> TCM (Exp, JSQName) global q = do   d <- getConstInfo q   case d of     Defn { theDef = Constructor { conData = p } } -> do-      e <- getConstInfo p-      case e of+      getConstInfo p >>= \case+        -- Andreas, 2020-10-27, comment quotes outdated fact.+        -- anon. constructors are now M.R.constructor.+        -- We could simplify/remove the workaround by switching "record"+        -- to "constructor", but this changes the output of the JS compiler+        -- maybe in ways that break user's developments+        -- (if they link to Agda-generated JS).+        -- -- Rather annoyingly, the anonymous constructor of a record R in module M+        -- -- is given the name M.recCon, but a named constructor C+        -- -- is given the name M.R.C, sigh. This causes a lot of hoop-jumping+        -- -- in the map from Agda names to JS names, which we patch by renaming+        -- -- anonymous constructors to M.R.record.         Defn { theDef = Record { recNamedCon = False } } -> do           (m,ls) <- global' p-          return (m, ls ++ [MemberId "record"])+          return (m, ls <> singleton (MemberId "record"))         _ -> global' (defName d)     _ -> global' (defName d) @@ -214,13 +309,13 @@     (vs, funs)    = partition isTopLevelValue es     (datas, vals) = partition isEmptyObject vs -reorder' :: Set [MemberId] -> [Export] -> [Export]+reorder' :: Set JSQName -> [Export] -> [Export] reorder' defs [] = [] reorder' defs (e : es) =-  let us = uses e `difference` defs in-  case null us of-    True -> e : (reorder' (insert (expName e) defs) es)-    False -> reorder' defs (insertAfter us e es)+  let us = uses e `Set.difference` defs+  in  if null us+        then e : (reorder' (Set.insert (expName e) defs) es)+        else reorder' defs (insertAfter us e es)  isTopLevelValue :: Export -> Bool isTopLevelValue (Export _ e) = case e of@@ -230,32 +325,23 @@  isEmptyObject :: Export -> Bool isEmptyObject (Export _ e) = case e of-  Object m -> Map.null m+  Object m -> null m   Lambda{} -> True   _        -> False -insertAfter :: Set [MemberId] -> Export -> [Export] -> [Export]-insertAfter us e []                 = [e]-insertAfter us e (f:fs) | null us   = e : f : fs-insertAfter us e (f:fs) | otherwise = f : insertAfter (delete (expName f) us) e fs+insertAfter :: Set JSQName -> Export -> [Export] -> [Export]+insertAfter us e []                   = [e]+insertAfter us e (f : fs) | null us   = e : f : fs+insertAfter us e (f : fs) | otherwise =+  f : insertAfter (Set.delete (expName f) us) e fs  -------------------------------------------------- -- Main compiling clauses -------------------------------------------------- -curModule :: IsMain -> TCM Module-curModule isMain = do-  kit <- coinductionKit-  m <- (jsMod <$> curMName)-  is <- map jsMod <$> (map fst . iImportedModules <$> curIF)-  es <- catMaybes <$> (mapM (definition kit) =<< (sortDefs <$> curDefs))-  return $ Module m (reorder es) main-  where-    main = case isMain of-      IsMain -> Just $ Apply (Lookup Self $ MemberId "main") [Lambda 1 emp]-      NotMain -> Nothing+type EnvWithOpts = (JSOptions, JSModuleEnv) -definition :: Maybe CoinductionKit -> (QName,Definition) -> TCM (Maybe Export)+definition :: EnvWithOpts -> (QName,Definition) -> TCM (Maybe Export) definition kit (q,d) = do   reportSDoc "compile.js" 10 $ "compiling def:" <+> prettyTCM q   (_,ls) <- global q@@ -281,20 +367,20 @@   where     dropEquals = dropWhile $ \ c -> isSpace c || c == '=' -definition' :: Maybe CoinductionKit -> QName -> Definition -> Type -> [MemberId] -> TCM (Maybe Export)-definition' kit q d t ls = do+definition' :: EnvWithOpts -> QName -> Definition -> Type -> JSQName -> TCM (Maybe Export)+definition' kit q d t ls = if not (usableModality d) then return Nothing else do   checkCompilerPragmas q   case theDef d of     -- coinduction-    Constructor{} | Just q == (nameOfSharp <$> kit) -> do+    Constructor{} | Just q == (nameOfSharp <$> snd kit) -> do       return Nothing-    Function{} | Just q == (nameOfFlat <$> kit) -> do+    Function{} | Just q == (nameOfFlat <$> snd kit) -> do       ret $ Lambda 1 $ Apply (Lookup (local 0) flatName) []      DataOrRecSig{} -> __IMPOSSIBLE__ -    Axiom | Just e <- defJSDef d -> plainJS e-    Axiom | otherwise -> ret Undefined+    Axiom{} | Just e <- defJSDef d -> plainJS e+    Axiom{} | otherwise -> ret Undefined      GeneralizableVar{} -> return Nothing @@ -303,54 +389,96 @@        reportSDoc "compile.js" 5 $ "compiling fun:" <+> prettyTCM q       caseMaybeM (toTreeless T.EagerEvaluation q) (pure Nothing) $ \ treeless -> do+        used <- fromMaybe [] <$> getCompiledArgUse q         funBody <- eliminateCaseDefaults =<<           eliminateLiteralPatterns           (convertGuards treeless)         reportSDoc "compile.js" 30 $ " compiled treeless fun:" <+> pretty funBody-        funBody' <- compileTerm funBody+        reportSDoc "compile.js" 40 $ " argument usage:" <+> (text . show) used++        let (body, given) = lamView funBody+              where+                lamView :: T.TTerm -> (T.TTerm, Int)+                lamView (T.TLam t) = (+1) <$> lamView t+                lamView t = (t, 0)++            -- number of eta expanded args+            etaN = length $ dropWhileEnd (== ArgUsed) $ drop given used++            unusedN = length $ filter (== ArgUnused) used++        funBody' <- compileTerm kit+                  $ iterate' (given + etaN - unusedN) T.TLam+                  $ eraseLocalVars (map (== ArgUnused) used)+                  $ T.mkTApp (raise etaN body) (T.TVar <$> downFrom etaN)+         reportSDoc "compile.js" 30 $ " compiled JS fun:" <+> (text . show) funBody'-        return $ Just $ Export ls funBody'+        return $+          if funBody' == Null then Nothing+          else Just $ Export ls funBody' -    Primitive{primName = p} | p `Set.member` primitives ->-      plainJS $ "agdaRTS." ++ p-    Primitive{} | Just e <- defJSDef d -> plainJS e-    Primitive{} | otherwise -> ret Undefined+    Primitive{primName = p}+      | p `Set.member` cubicalPrimitives ->+        typeError $ NotImplemented p+      | p `Set.member` primitives ->+        plainJS $ "agdaRTS." ++ p+      | Just e <- defJSDef d ->+        plainJS e+      | otherwise ->+        ret Undefined+    PrimitiveSort{} -> return Nothing -    Datatype{} -> ret emp-    Record{} -> return Nothing+    Datatype{ dataPathCons = _ : _ } -> do+      s <- render <$> prettyTCM q+      typeError $ NotImplemented $+        "Higher inductive types (" ++ s ++ ")"+    Datatype{} -> do+        computeErasedConstructorArgs q+        ret emp+    Record{} -> do+        computeErasedConstructorArgs q+        return Nothing      Constructor{} | Just e <- defJSDef d -> plainJS e-    Constructor{conData = p, conPars = nc} | otherwise -> do-      np <- return (arity t - nc)+    Constructor{conData = p, conPars = nc} -> do+      let np = arity t - nc+      erased <- getErasedConArgs q+      let nargs = np - length (filter id erased)+          args = [ Local $ LocalId $ nargs - i | i <- [0 .. nargs-1] ]       d <- getConstInfo p+      let l = List1.last ls       case theDef d of-        Record { recFields = flds } ->-          ret (curriedLambda np (Object (fromList-            ( (last ls , Lambda 1-                 (Apply (Lookup (Local (LocalId 0)) (last ls))-                   [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))-            : (zip [ jsMember (qnameName (unDom fld)) | fld <- flds ]-                 [ Local (LocalId (np - i)) | i <- [1 .. np] ])))))-        _ ->-          ret (curriedLambda (np + 1)-            (Apply (Lookup (Local (LocalId 0)) (last ls))-              [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))+        Record { recFields = flds } -> ret $ curriedLambda nargs $+          if optJSOptimize (fst kit)+            then Lambda 1 $ Apply (Local (LocalId 0)) args+            else Object $ Map.fromList [ (l, Lambda 1 $ Apply (Lookup (Local (LocalId 0)) l) args) ]+        dt -> do+          i <- index+          ret $ curriedLambda (nargs + 1) $ Apply (Lookup (Local (LocalId 0)) i) args+          where+            index :: TCM MemberId+            index+              | Datatype{} <- dt+              , optJSOptimize (fst kit) = do+                  q  <- canonicalName q+                  cs <- mapM canonicalName $ defConstructors dt+                  case findIndex (q ==) cs of+                    Just i  -> return $ MemberIndex i (mkComment l)+                    Nothing -> __IMPOSSIBLE_VERBOSE__ $ unwords [ "Constructor", prettyShow q, "not found in", prettyShow cs ]+              | otherwise = return l+            mkComment (MemberId s) = Comment s+            mkComment _ = mempty      AbstractDefn{} -> __IMPOSSIBLE__   where     ret = return . Just . Export ls     plainJS = return . Just . Export ls . PlainJS -compileTerm :: T.TTerm -> TCM Exp-compileTerm t = do-  kit <- coinductionKit-  compileTerm' kit t--compileTerm' :: Maybe CoinductionKit -> T.TTerm -> TCM Exp-compileTerm' kit t = go t+compileTerm :: EnvWithOpts -> T.TTerm -> TCM Exp+compileTerm kit t = go t   where     go :: T.TTerm -> TCM Exp-    go t = case t of+    go = \case       T.TVar x -> return $ Local $ LocalId x       T.TDef q -> do         d <- getConstInfo q@@ -359,7 +487,7 @@           Datatype {} -> return (String "*")           Record {} -> return (String "*")           _ -> qname q-      T.TApp (T.TCon q) [x] | Just q == (nameOfSharp <$> kit) -> do+      T.TApp (T.TCon q) [x] | Just q == (nameOfSharp <$> snd kit) -> do         x <- go x         let evalThunk = unlines               [ "function() {"@@ -373,7 +501,23 @@         return $ Object $ Map.fromList           [(flatName, PlainJS evalThunk)           ,(MemberId "__flat_helper", Lambda 0 x)]-      T.TApp t xs -> curriedApply <$> go t <*> mapM go xs+      T.TApp t' xs | Just f <- getDef t' -> do+        used <- case f of+          Left  q -> fromMaybe [] <$> getCompiledArgUse q+          Right c -> map (\ b -> if b then ArgUnused else ArgUsed) <$> getErasedConArgs c+            -- Andreas, 2021-02-10 NB: could be @map (bool ArgUsed ArgUnused)@+            -- but I find it unintuitive that 'bool' takes the 'False'-branch first.+        let given = length xs++            -- number of eta expanded args+            etaN = length $ dropWhile (== ArgUsed) $ reverse $ drop given used++            args = filterUsed used $ xs ++ (T.TVar <$> downFrom etaN)++        curriedLambda etaN <$> (curriedApply <$> go (raise etaN t') <*> mapM go args)++      T.TApp t xs -> do+            curriedApply <$> go t <*> mapM go xs       T.TLam t -> Lambda 1 <$> go t       -- TODO This is not a lazy let, but it should be...       T.TLet t e -> apply <$> (Lambda 1 <$> go e) <*> traverse go [t]@@ -381,16 +525,22 @@       T.TCon q -> do         d <- getConstInfo q         qname q-      T.TCase sc ct def alts | T.CTData dt <- T.caseType ct -> do+      T.TCase sc ct def alts | T.CTData _ dt <- T.caseType ct -> do         dt <- getConstInfo dt-        alts' <- traverse compileAlt alts-        let obj = Object $ Map.fromList alts'+        alts' <- traverse (compileAlt kit) alts+        let cs  = defConstructors $ theDef dt+            obj = Object $ Map.fromList [(snd x, y) | (x, y) <- alts']+            arr = mkArray [headWithDefault (mempty, Null) [(Comment s, y) | ((c', MemberId s), y) <- alts', c' == c] | c <- cs]         case (theDef dt, defJSDef dt) of           (_, Just e) -> do             return $ apply (PlainJS e) [Local (LocalId sc), obj]+          (Record{}, _) | optJSOptimize (fst kit) -> do+            return $ apply (Local $ LocalId sc) [snd $ headWithDefault __IMPOSSIBLE__ alts']           (Record{}, _) -> do             memId <- visitorName $ recCon $ theDef dt             return $ apply (Lookup (Local $ LocalId sc) memId) [obj]+          (Datatype{}, _) | optJSOptimize (fst kit) -> do+            return $ curriedApply (Local (LocalId sc)) [arr]           (Datatype{}, _) -> do             return $ curriedApply (Local (LocalId sc)) [obj]           _ -> __IMPOSSIBLE__@@ -401,10 +551,20 @@       T.TSort -> unit       T.TErased -> unit       T.TError T.TUnreachable -> return Undefined+      T.TError T.TMeta{}      -> return Undefined       T.TCoerce t -> go t -    unit = return $ Integer 0+    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.fromList [(MemberIndex i c, x) | (i, (c, x)) <- zip [0..] xs, x /= Null]+ compilePrim :: T.TPrim -> Exp compilePrim p =   case p of@@ -436,16 +596,23 @@         primEq   = curriedLambda 2 $ BinOp (local 1) "===" (local 0)  -compileAlt :: T.TAlt -> TCM (MemberId, Exp)-compileAlt a = case a of+compileAlt :: EnvWithOpts -> T.TAlt -> TCM ((QName, MemberId), Exp)+compileAlt kit = \case   T.TACon con ar body -> do+    erased <- getErasedConArgs con+    let nargs = ar - length (filter id erased)     memId <- visitorName con-    body <- Lambda ar <$> compileTerm body-    return (memId, body)+    body <- Lambda nargs <$> compileTerm kit (eraseLocalVars erased body)+    return ((con, memId), body)   _ -> __IMPOSSIBLE__ +eraseLocalVars :: [Bool] -> T.TTerm -> T.TTerm+eraseLocalVars [] x = x+eraseLocalVars (False: es) x = eraseLocalVars es x+eraseLocalVars (True: es) x = eraseLocalVars es (TC.subst (length es) T.TErased x)+ visitorName :: QName -> TCM MemberId-visitorName q = do (m,ls) <- global q; return (last ls)+visitorName q = do (m,ls) <- global q; return (List1.last ls)  flatName :: MemberId flatName = MemberId "flat"@@ -459,25 +626,25 @@   return (foldl Lookup e ls)  literal :: Literal -> Exp-literal l = case l of-  (LitNat    _ x) -> Integer x-  (LitWord64 _ x) -> Integer (fromIntegral x)-  (LitFloat  _ x) -> Double  x-  (LitString _ x) -> String  x-  (LitChar   _ x) -> Char    x-  (LitQName  _ x) -> litqname x-  LitMeta{}       -> __IMPOSSIBLE__+literal = \case+  (LitNat    x) -> Integer x+  (LitWord64 x) -> Integer (fromIntegral x)+  (LitFloat  x) -> Double  x+  (LitString x) -> String  x+  (LitChar   x) -> Char    x+  (LitQName  x) -> litqname x+  LitMeta{}     -> __IMPOSSIBLE__  litqname :: QName -> Exp litqname q =   Object $ Map.fromList     [ (mem "id", Integer $ fromIntegral n)     , (mem "moduleId", Integer $ fromIntegral m)-    , (mem "name", String $ prettyShow q)+    , (mem "name", String $ T.pack $ prettyShow q)     , (mem "fixity", litfixity fx)]   where     mem = MemberId-    NameId n m = nameId $ qnameName q+    NameId n (ModuleNameHash m) = nameId $ qnameName q     fx = theFixity $ nameFixity $ qnameName q      litfixity :: Fixity -> Exp@@ -497,10 +664,10 @@ -- Writing out an ECMAScript module -------------------------------------------------- -writeModule :: Module -> TCM ()-writeModule m = do+writeModule :: Bool -> Module -> TCM ()+writeModule minify m = do   out <- outFile (modName m)-  liftIO (writeFile out (JSPretty.pretty 0 0 m))+  liftIO (writeFile out (JSPretty.prettyShow minify m))  outFile :: GlobalId -> TCM FilePath outFile m = do@@ -516,40 +683,164 @@   m <- curMName   outFile (jsMod m) -copyRTEModules :: TCM ()-copyRTEModules = do-  dataDir <- lift getDataDir-  let srcDir = dataDir </> "JS"-  (lift . copyDirContent srcDir) =<< compileDir+-- | Cubical primitives that are (currently) not compiled.+--+-- TODO: Primitives that are neither part of this set nor of+-- 'primitives', and for which 'defJSDef' does not return anything,+-- are silently compiled to 'Undefined'. Thus, if a cubical primitive+-- is by accident omitted from 'cubicalPrimitives', then programs that+-- should be rejected are compiled to something which might not work+-- as intended. A better approach might be to list exactly those+-- primitives which should be compiled to 'Undefined'. +cubicalPrimitives :: Set String+cubicalPrimitives = Set.fromList+  [ "primIMin"+  , "primIMax"+  , "primINeg"+  , "primPartial"+  , "primPartialP"+  , "primPFrom1"+  , "primPOr"+  , "primComp"+  , "primTransp"+  , "primHComp"+  , "primSubOut"+  ]+ -- | Primitives implemented in the JS Agda RTS. primitives :: Set String primitives = Set.fromList-  [ "primExp"-  , "primFloatDiv"+  [  "primShowInteger"++  -- Natural number functions+  -- , "primNatPlus"                 -- missing+  , "primNatMinus"+  -- , "primNatTimes"                -- missing+  -- , "primNatDivSucAux"            -- missing+  -- , "primNatModSucAux"            -- missing+  -- , "primNatEquality"             -- missing+  -- , "primNatLess"                 -- missing+  -- , "primShowNat"                 -- missing++  -- Machine words+  , "primWord64ToNat"+  , "primWord64FromNat"+  -- , "primWord64ToNatInjective"    -- missing++  -- Level functions+  -- , "primLevelZero"               -- missing+  -- , "primLevelSuc"                -- missing+  -- , "primLevelMax"                -- missing++  -- Sorts+  -- , "primSetOmega"                -- missing+  -- , "primStrictSetOmega"          -- missing++  -- Floating point functions   , "primFloatEquality"+  , "primFloatInequality"   , "primFloatLess"-  , "primFloatNumericalEquality"-  , "primFloatNumericalLess"-  , "primFloatNegate"-  , "primFloatMinus"+  , "primFloatIsInfinite"+  , "primFloatIsNaN"+  , "primFloatIsNegativeZero"+  , "primFloatIsSafeInteger"+  , "primFloatToWord64"+  -- , "primFloatToWord64Injective"  -- missing+  , "primNatToFloat"+  , "primIntToFloat"+  -- , "primFloatRound"              -- in Agda.Builtin.Float+  -- , "primFloatFloor"              -- in Agda.Builtin.Float+  -- , "primFloatCeiling"            -- in Agda.Builtin.Float+  -- , "primFloatToRatio"            -- in Agda.Builtin.Float+  , "primRatioToFloat"+  -- , "primFloatDecode"             -- in Agda.Builtin.Float+  -- , "primFloatEncode"             -- in Agda.Builtin.Float+  , "primShowFloat"   , "primFloatPlus"-  , "primFloatSqrt"+  , "primFloatMinus"   , "primFloatTimes"-  , "primNatMinus"-  , "primShowFloat"-  , "primShowInteger"-  , "primSin"-  , "primCos"-  , "primTan"-  , "primASin"-  , "primACos"-  , "primATan"-  , "primATan2"-  , "primShowQName"+  , "primFloatNegate"+  , "primFloatDiv"+  , "primFloatSqrt"+  , "primFloatExp"+  , "primFloatLog"+  , "primFloatSin"+  , "primFloatCos"+  , "primFloatTan"+  , "primFloatASin"+  , "primFloatACos"+  , "primFloatATan"+  , "primFloatATan2"+  , "primFloatSinh"+  , "primFloatCosh"+  , "primFloatTanh"+  , "primFloatASinh"+  , "primFloatACosh"+  , "primFloatATanh"+  , "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+  -- , "primCharToNatInjective"      -- missing+  -- , "primNatToChar"               -- missing+  -- , "primShowChar"                -- in Agda.Builtin.String++  -- String functions+  -- , "primStringToList"            -- in Agda.Builtin.String+  -- , "primStringToListInjective"   -- missing+  -- , "primStringFromList"          -- in Agda.Builtin.String+  -- , "primStringFromListInjective" -- missing+  -- , "primStringAppend"            -- in Agda.Builtin.String+  -- , "primStringEquality"          -- in Agda.Builtin.String+  -- , "primShowString"              -- in Agda.Builtin.String+  -- , "primStringUncons"            -- in Agda.Builtin.String++  -- Other stuff+  -- , "primEraseEquality"           -- missing+  -- , "primForce"                   -- missing+  -- , "primForceLemma"              -- missing   , "primQNameEquality"   , "primQNameLess"+  , "primShowQName"   , "primQNameFixity"-  , "primWord64ToNat"-  , "primWord64FromNat"+  -- , "primQNameToWord64s"          -- missing+  -- , "primQNameToWord64sInjective" -- missing+  -- , "primMetaEquality"            -- missing+  -- , "primMetaLess"                -- missing+  -- , "primShowMeta"                -- missing+  -- , "primMetaToNat"               -- missing+  -- , "primMetaToNatInjective"      -- missing+  -- , "primIMin"                    -- missing+  -- , "primIMax"                    -- missing+  -- , "primINeg"                    -- missing+  -- , "primPOr"                     -- missing+  -- , "primComp"                    -- missing+  -- , builtinTrans                  -- missing+  -- , builtinHComp                  -- missing+  -- , "primIdJ"                     -- missing+  -- , "primPartial"                 -- missing+  -- , "primPartialP"                -- missing+  -- , builtinGlue                   -- missing+  -- , builtin_glue                  -- missing+  -- , builtin_unglue                -- missing+  -- , builtinFaceForall             -- missing+  -- , "primDepIMin"                 -- missing+  -- , "primIdFace"                  -- missing+  -- , "primIdPath"                  -- missing+  -- , builtinIdElim                 -- missing+  -- , builtinSubOut                 -- missing+  -- , builtin_glueU                 -- missing+  -- , builtin_unglueU               -- missing   ]

src/full/Agda/Compiler/JS/Pretty.hs view

@@ -1,25 +1,187 @@ module Agda.Compiler.JS.Pretty where -import Prelude hiding ( null ) import Data.Char ( isAsciiLower, isAsciiUpper, isDigit ) import Data.List ( intercalate )+import Data.String ( IsString (fromString) )+import Data.Semigroup ( Semigroup, (<>) ) import Data.Set ( Set, toList, singleton, insert, member )+import qualified Data.Set as Set import Data.Map ( Map, toAscList, empty, null )+import qualified Data.Text as T  import Agda.Syntax.Common ( Nat )+ import Agda.Utils.Hash+import Agda.Utils.List ( indexWithDefault )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1 +import Agda.Utils.Impossible+ import Agda.Compiler.JS.Syntax hiding (exports)  -- Pretty-print a lambda-calculus expression as ECMAScript. --- Since ECMAScript is C-like rather than Haskell-like, it's easier to--- do the pretty-printing directly than use the Pretty library, which--- assumes Haskell-like indentation.+--- The indentation combinators of the pretty library does not fit C-like languages+--- like ECMAScript.+--- A simple pretty printer is implemented with a better `indent` and punctuation compaction.+---+--- More explanation:+---+--- I have struggled with different pretty printers, and at the end it was much easier+--- to implement and use this ~100 SLOC code pretty printer library.+--- It produces really better quality indentation than I could achieve with the+--  standard pretty printers.+--- This library code is only used in this module, and it is specialized to pretty+--- print JavaScript code for the Agda backend, so I think its best place is in this module.+data Doc+    = Doc String+    | Indent Int Doc+    | Group Doc+    | Beside Doc Doc+    | Above Doc Doc+    | Enclose Doc Doc Doc+    | Space+    | Empty -br :: Int -> String-br i = "\n" ++ take (2*i) (repeat ' ')+minifiedCodeLinesLength :: Int+minifiedCodeLinesLength = 500 +render :: Bool -> Doc -> String+render minify = intercalate "\n" . joinLines . map (uncurry mkIndent) . go 0+  where+    joinLines :: [String] -> [String]+    joinLines = if minify then chunks 0 [] else id+      where+        chunks len acc [] = [concat (reverse acc)]+        chunks len acc (s: ss)+            | len + n <= minifiedCodeLinesLength = chunks (len + n) (s: acc) ss+            | otherwise = concat (reverse acc): chunks n [s] ss+          where+            n = length s++    joinBy f [x] (y: ys) = f x y ++ ys+    joinBy f (x:xs) ys = x: joinBy f xs ys+    joinBy f xs ys = xs ++ ys++    mkIndent n s | minify = s+    mkIndent n "" = ""+    mkIndent n s = replicate n ' ' ++ s++    overlay (i, s) (j, s') | all punctuation (s ++ s') && n > 0 = [(i, s ++ mkIndent n s')]+      where n = j - (i + length s)+    overlay (j, s') (i, s) | all punctuation (s ++ s') && n > 0 = [(i, s' ++ mkIndent n s)]+      where n = j - (i + length s)+    overlay a b = [a, b]++    punctuation = (`elem` ("(){}[];:, " :: String))++    go i Space = if minify then [] else [(i, " ")]+    go i Empty = []+    go i (Doc s) = [(i, s)]+    go i (Beside d d') = joinBy (\(i, s) (_, s') -> [(i, s ++ s')]) (go i d) (go i d')+    go i (Above d d') = joinBy overlay (go i d) (go i d')+    go i (Indent j d) = go (i+j) d+    go i (Enclose open close d) = go i $ Group $ Above open $ Above d close+    go i (Group d)+        | size ss < 40 = compact ss+        | otherwise    = ss+      where+        ss = go i d+        size = sum . map (length . snd)+        compact [] = []+        compact ((i, x): xs) = [(i, x ++ concatMap snd xs)]++instance IsString Doc where+    fromString = Doc++instance Semigroup Doc where+    Empty <> d = d+    d <> Empty = d+    d <> d' = Beside d d'++instance Monoid Doc where+    mempty = Empty+    mappend = (<>)++infixr 5 $+$+infixr 5 $++$+infixr 6 <+>  -- fixity has to match the one of Semigroup.(<>)++($+$) :: Doc -> Doc -> Doc+Empty $+$ d = d+d $+$ Empty = d+d $+$ d' = Above d d'++-- | Separate by blank line.++($++$) :: Doc -> Doc -> Doc+Empty $++$ d = d+d $++$ Empty = d+d $++$ d' = d `Above` "" `Above` d'++-- | Separate by space that will be removed by minify.+--+-- For non-removable space, use @d <> " " <> d'@.++(<+>) :: Doc -> Doc -> Doc+Empty <+> d = d+d <+> Empty = d+d <+> d' = d `Beside` Space `Beside` d'++text :: String -> Doc+text = Doc++group :: Doc -> Doc+group = Group++indentBy :: Int -> Doc -> Doc+indentBy i Empty = Empty+indentBy i (Indent j d) = Indent (i+j) d+indentBy i d = Indent i d++enclose :: Doc -> Doc -> Doc -> Doc+enclose open close (Enclose o c d) = Enclose (open <> o) (c <> close) d+enclose open close (Indent _ (Enclose o c d)) = Enclose (open <> o) (c <> close) d+enclose open close d = Enclose open close d++----------------------------------------------------------------------------------------------++space :: Doc+space = Space++indent :: Doc -> Doc+indent = indentBy 2++hcat :: [Doc] -> Doc+hcat = foldr (<>) mempty++vcat :: [Doc] -> Doc+vcat = foldr ($+$) mempty++-- | Concatenate vertically, separated by blank lines.++vsep :: [Doc] -> Doc+vsep = foldr ($++$) mempty++punctuate :: Doc -> [Doc] -> Doc+punctuate _ []     = mempty+punctuate p (x:xs) = indent $ vcat $ go x xs+                   where go y []     = [y]+                         go y (z:zs) = (y <> p) : go z zs++parens, brackets, braces :: Doc -> Doc+parens   = enclose "(" ")"+brackets = enclose "[" "]"+braces   = enclose "{" "}"++-- | Apply 'parens' to 'Doc' if boolean is true.+mparens :: Bool -> Doc -> Doc+mparens True  d = parens d+mparens False d = d++----------------------------------------------------------------------------------------------+ unescape :: Char -> String unescape '"'      = "\\\"" unescape '\\'     = "\\\\"@@ -29,98 +191,123 @@ unescape '\x2029' = "\\u2029" unescape c        = [c] -unescapes :: String -> String-unescapes s = concat (map unescape s)+unescapes :: String -> Doc+unescapes s = text $ concatMap unescape s --- pretty n i e pretty-prints e, under n levels of de Bruijn binding,--- with i levels of indentation.+-- pretty (n,b) i e pretty-prints e, under n levels of de Bruijn binding+--   if b is true then the output is minified  class Pretty a where-    pretty :: Nat -> Int -> a -> String+    pretty :: (Nat, Bool) -> a -> Doc +prettyShow :: Pretty a => Bool -> a -> String+prettyShow minify = render minify . pretty (0, minify)++instance Pretty a => Pretty (Maybe a) where+  pretty n = maybe mempty (pretty n)+ instance (Pretty a, Pretty b) => Pretty (a,b) where-  pretty n i (x,y) = pretty n i x ++ ": " ++ pretty n (i+1) y+  pretty n (x,y) = pretty n x <> ":" <+> pretty n y  -- Pretty-print collections  class Pretties a where-    pretties :: Nat -> Int -> a -> [String]+    pretties :: (Nat, Bool) -> a -> [Doc]  instance Pretty a => Pretties [a] where-  pretties n i = map (pretty n i)+  pretties n = map (pretty n) +instance Pretty a => Pretties (List1 a) where+  pretties n = pretties n . List1.toList+ instance (Pretty a, Pretty b) => Pretties (Map a b) where-  pretties n i o = pretties n i (toAscList o)+  pretties n = pretties n . toAscList  -- Pretty print identifiers  instance Pretty LocalId where-  pretty n i (LocalId x) = "x" ++ show (n - x - 1)+  pretty (n, _) (LocalId x) = text $ indexWithDefault __IMPOSSIBLE__ vars (n - x - 1)+    where+      vars = ("": map show [0..]) >>= \s -> map (:s) ['a'..'z']  instance Pretty GlobalId where-  pretty n i (GlobalId m) = variableName $ intercalate "_" m+  pretty n (GlobalId m) = text $ variableName $ intercalate "_" m  instance Pretty MemberId where-  pretty n i (MemberId s) = "\"" ++ unescapes s ++ "\""+  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 print expressions  instance Pretty Exp where-  pretty n i (Self)                 = "exports"-  pretty n i (Local x)              = pretty n i x-  pretty n i (Global m)             = pretty n i m-  pretty n i (Undefined)            = "undefined"-  pretty n i (String s)             = "\"" ++ unescapes s ++ "\""-  pretty n i (Char c)               = "\"" ++ unescape c ++ "\""-  pretty n i (Integer x)            = "agdaRTS.primIntegerFromString(\"" ++ show x ++ "\")"-  pretty n i (Double x)             = show x-  pretty n i (Lambda x e)           =-    "function (" ++-      intercalate ", " (pretties (n+x) i (map LocalId [x-1, x-2 .. 0])) ++-    ") " ++ block (n+x) i e-  pretty n i (Object o) | null o    = "{}"-  pretty n i (Object o) | otherwise =-    "{" ++ br (i+1) ++ intercalate ("," ++ br (i+1)) (pretties n i o) ++ br i ++ "}"-  pretty n i (Apply f es)           = pretty n i f ++ "(" ++ intercalate ", " (pretties n i es) ++ ")"-  pretty n i (Lookup e l)           = pretty n i e ++ "[" ++ pretty n i l ++ "]"-  pretty n i (If e f g)             =-    "(" ++ pretty n i e ++ "? " ++ pretty n i f ++ ": " ++ pretty n i g ++ ")"-  pretty n i (PreOp op e)           = "(" ++ op ++ " " ++ pretty n i e ++ ")"-  pretty n i (BinOp e op f)         = "(" ++ pretty n i e ++ " " ++ op ++ " " ++ pretty n i f ++ ")"-  pretty n i (Const c)              = c-  pretty n i (PlainJS js)           = "(" ++ js ++ ")"--block :: Nat -> Int -> Exp -> String-block n i (If e f g) = "{" ++ br (i+1) ++ block' n (i+1) (If e f g) ++ br i ++ "}"-block n i e          = "{" ++ br (i+1) ++ "return " ++ pretty n (i+1) e ++ ";" ++ br i ++ "}"+  pretty n (Self)            = "exports"+  pretty n (Local x)         = pretty n x+  pretty n (Global m)        = pretty n m+  pretty n (Undefined)       = "undefined"+  pretty n (Null)            = "null"+  pretty n (String s)        = "\"" <> unescapes (T.unpack s) <> "\""+  pretty n (Char c)          = "\"" <> unescapes [c] <> "\""+  pretty n (Integer x)       = "agdaRTS.primIntegerFromString(\"" <> text (show x) <> "\")"+  pretty n (Double x)        = text $ show x+  pretty (n, min) (Lambda x e) =+    mparens (x /= 1) (punctuate "," (pretties (n+x, min) (map LocalId [x-1, x-2 .. 0])))+    <+> "=>" <+> block (n+x, min) e+  pretty n (Object o)        = braces $ punctuate "," $ pretties n o+  pretty n (Array es)        = brackets $ punctuate "," [pretty n c <> pretty n e | (c, e) <- es]+  pretty n (Apply f es)      = pretty n f <> parens (punctuate "," $ pretties n es)+  pretty n (Lookup e l)      = pretty n e <> brackets (pretty n l)+  pretty n (If e f g)        = parens $ pretty n e <> "?" <+> pretty n f <> ":" <+> pretty n g+  pretty n (PreOp op e)      = parens $ text op <> " " <> pretty n e+  pretty n (BinOp e op f)    = parens $ pretty n e <> " " <> text op <> " " <> pretty n f+  pretty n (Const c)         = text c+  pretty n (PlainJS js)      = text js -block' :: Nat -> Int -> Exp -> String-block' n i (If e f g) = "if (" ++ pretty n i e ++ ") " ++ block n i f ++ " else " ++ block' n i g-block' n i e          = block n i e+block :: (Nat, Bool) -> Exp -> Doc+block n e = mparens (doNest e) $ pretty n e+  where+    doNest Object{} = True+    doNest _ = False -modname :: GlobalId -> String-modname (GlobalId ms) = "\"" ++ intercalate "." ms ++ "\""+modname :: GlobalId -> Doc+modname (GlobalId ms) = text $ "\"" ++ intercalate "." ms ++ "\"" +exports :: (Nat, Bool) -> Set JSQName -> [Export] -> Doc+exports n lss [] = Empty+exports n lss es0@(Export ls e : es)+  -- If the parent of @ls@ is already defined (or no parent exists), @ls@ can be defined+  | maybe True (`member` lss) parent =+      "exports" <> hcat (map brackets (pretties n ls)) <+> "=" <+> indent (pretty n e) <> ";" $+$+      exports n (insert ls lss) es+  -- If the parent is not yet defined, first define it as empty object, and then continue with @ls@.+  | otherwise =+      exports n lss $ maybe es0 (\ ls' -> Export ls' (Object mempty) : es0) parent+  where+  parent = List1.nonEmpty $ List1.init ls -exports :: Nat -> Int -> Set [MemberId] -> [Export] -> String-exports n i lss [] = ""-exports n i lss (Export ls e : es) | member (init ls) lss =-  "exports[" ++ intercalate "][" (pretties n i ls) ++ "] = " ++ pretty n (i+1) e ++ ";" ++ br i ++-  exports n i (insert ls lss) es-exports n i lss (Export ls e : es) | otherwise =-  exports n i lss (Export (init ls) (Object empty) : Export ls e : es)+instance Pretty [(GlobalId, Export)] where+  pretty n es+    = vcat [ pretty n g <> hcat (map brackets (pretties n ls)) <+> "=" <+> indent (pretty n e) <> ";"+           | (g, Export ls e) <- es ]  instance Pretty Module where-  pretty n i (Module m es ex) =-    imports ++ br i-      ++ exports n i (singleton []) es ++ br i-      ++ maybe "" (pretty n i) ex+  pretty n (Module m is es callMain) = vsep+    [ importRTS+    , imports+    , exports n Set.empty es+    , pretty n callMain+    ]+    $+$ "" -- Final newline     where-      js = toList (globals es)-      imports = unlines $-            ["var agdaRTS = require(\"agda-rts\");"] ++-            ["var " ++ pretty n (i+1) e ++ " = require(" ++ modname e ++ ");"-            | e <- js]+      importRTS = "var agdaRTS" <+> "=" <+> "require(\"agda-rts\");"+      imports   = vcat+        [ "var " <> indent (pretty n e) <+> "=" <+> "require(" <> modname e <> ");"+        | e <- toList (globals es <> Set.fromList is)+        ]  variableName :: String -> String variableName s = if isValidJSIdent s then "z_" ++ s else "h_" ++ show (hashString s)

src/full/Agda/Compiler/JS/Substitution.hs view

@@ -8,9 +8,10 @@  import Agda.Syntax.Common ( Nat ) import Agda.Compiler.JS.Syntax-  ( Exp(Self,Undefined,Local,Lambda,Object,Apply,Lookup,If,BinOp,PreOp),+  ( Exp(Self,Undefined,Local,Lambda,Object,Array,Apply,Lookup,If,BinOp,PreOp),     MemberId, LocalId(LocalId) ) import Agda.Utils.Function ( iterate' )+import Agda.Utils.List ( indexWithDefault )  -- Map for expressions @@ -18,6 +19,7 @@ map m f (Local i)       = f m i 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 (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'')@@ -55,6 +57,7 @@ map' m f (Local i)       = f m i 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 (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'')@@ -85,6 +88,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 (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)

src/full/Agda/Compiler/JS/Syntax.hs view

@@ -1,13 +1,18 @@  module Agda.Compiler.JS.Syntax where -import Data.Map ( Map )-import qualified Data.Map as Map+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Semigroup ( Semigroup ) -import Data.Set ( Set, empty, singleton, union )+import Data.Text (Text)  import Agda.Syntax.Common ( Nat ) +import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1+ -- An untyped lambda calculus with records, -- and a special self-binder for recursive declarations @@ -16,12 +21,14 @@   Local LocalId |   Global GlobalId |   Undefined |-  String String |+  Null |+  String Text |   Char Char |   Integer Integer |   Double Double |   Lambda Nat Exp |   Object (Map MemberId Exp) |+  Array [(Comment, Exp)] |   Apply Exp [Exp] |   Lookup Exp MemberId |   If Exp Exp Exp |@@ -29,7 +36,7 @@   PreOp String Exp |   Const String |   PlainJS String -- ^ Arbitrary JS code.-  deriving Show+  deriving (Show, Eq)  -- Local identifiers are named by De Bruijn indices. -- Global identifiers are named by string lists.@@ -41,16 +48,31 @@ newtype GlobalId = GlobalId [String]   deriving (Eq, Ord, Show) -newtype MemberId = MemberId String+data MemberId+    = MemberId String+    | MemberIndex Int Comment   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 -data Export = Export { expName :: [MemberId], defn :: Exp }+data Export = Export { expName :: JSQName, defn :: Exp }   deriving Show -data Module = Module { modName :: GlobalId, exports :: [Export], postscript :: Maybe Exp }+type JSQName = List1 MemberId++data Module = Module+  { modName  :: GlobalId+  , imports  :: [GlobalId]+  , exports  :: [Export]+  , callMain :: Maybe Exp+  }   deriving Show  -- Note that modules are allowed to be recursive, via the Self expression,@@ -59,25 +81,37 @@ -- Top-level uses of the form exports.l1....lN.  class Uses a where-  uses :: a -> Set [MemberId]+  uses :: a -> Set JSQName -instance Uses a => Uses [a] where-  uses = foldr (union . uses) empty+  default uses :: (a ~ t b, Foldable t, Uses b) => a -> Set JSQName+  uses = foldMap uses -instance Uses a => Uses (Map k a) where-  uses = Map.foldr (union . uses) empty+instance Uses a => Uses [a]+instance Uses a => Uses (Map k a) +instance (Uses a, Uses b) => Uses (a, b) where+  uses (a, b) = uses a `Set.union` uses b++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 (Object o)     = Map.foldr (union . uses) empty o-  uses (Apply e es)   = foldr (union . uses) (uses e) es-  uses (Lookup e l)   = uses' e [l] where-      uses' Self         ls = singleton ls-      uses' (Lookup e l) ls = uses' e (l : ls)+  uses (Object o)     = uses o+  uses (Array es)     = uses es+  uses (Apply e es)   = uses (e, es)+  uses (Lookup e l)   = uses' e (List1.singleton l)+    where+      uses' :: Exp -> JSQName -> Set JSQName+      uses' Self         ls = Set.singleton ls+      uses' (Lookup e l) ls = uses' e (l <| ls)       uses' e            ls = uses e-  uses (If e f g)     = uses e `union` uses f `union` uses g-  uses (BinOp e op f) = uses e `union` uses f+  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              = empty+  uses e              = Set.empty  instance Uses Export where   uses (Export _ e) = uses e@@ -87,25 +121,36 @@ class Globals a where   globals :: a -> Set GlobalId -instance Globals a => Globals [a] where-  globals = foldr (union . globals) empty+  default globals :: (a ~ t b, Foldable t, Globals b) => a -> Set GlobalId+  globals = foldMap globals -instance Globals a => Globals (Map k a) where-  globals = Map.foldr (union . globals) empty+instance Globals a => Globals [a]+instance Globals a => Globals (Maybe a)+instance Globals a => Globals (Map k a) +instance (Globals a, Globals b) => Globals (a, b) where+  globals (a, b) = globals a `Set.union` globals b++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 (Global i) = singleton i+  globals (Global i) = Set.singleton i   globals (Lambda n e) = globals e   globals (Object o) = globals o-  globals (Apply e es) = globals e `union` globals es+  globals (Array es) = globals es+  globals (Apply e es) = globals (e, es)   globals (Lookup e l) = globals e-  globals (If e f g) = globals e `union` globals f `union` globals g-  globals (BinOp e op f) = globals e `union` globals f+  globals (If e f g) = globals (e, f, g)+  globals (BinOp e op f) = globals (e, f)   globals (PreOp op e) = globals e-  globals _ = empty+  globals _ = Set.empty  instance Globals Export where   globals (Export _ e) = globals e  instance Globals Module where-  globals (Module m es _) = globals es+  globals (Module _ _ es me) = globals (es, me)

src/full/Agda/Compiler/MAlonzo/Coerce.hs view

@@ -5,10 +5,14 @@ import Agda.Syntax.Treeless  import Agda.TypeChecking.Monad+  ( HasConstInfo+  , getErasedConArgs+  , getTreeless+  )  -- | Insert unsafeCoerce (in the form of 'TCoerce') everywhere it's needed in --   the right-hand side of a definition.-addCoercions :: TTerm -> TCM TTerm+addCoercions :: HasConstInfo m => TTerm -> m TTerm addCoercions = coerceTop   where     -- Don't coerce top-level lambdas.@@ -65,12 +69,12 @@         TLet e b       -> TLet <$> softCoerce e <*> softCoerce b         TCase x t d bs -> TCase x t <$> coerce d <*> mapM coerceAlt bs -funArity :: TTerm -> TCM Nat+funArity :: HasConstInfo m => TTerm -> m Nat funArity (TDef q)  = maybe 0 (fst . tLamView) <$> getTreeless q funArity (TCon q)  = erasedArity q funArity (TPrim _) = return 3 -- max arity of any primitive funArity _         = return 0  -- | The number of retained arguments after erasure.-erasedArity :: QName -> TCM Nat+erasedArity :: HasConstInfo m => QName -> m Nat erasedArity q = length . filter not <$> getErasedConArgs q

src/full/Agda/Compiler/MAlonzo/Compiler.hs view

@@ -1,15 +1,24 @@  module Agda.Compiler.MAlonzo.Compiler where -import Control.Monad.Reader hiding (mapM_, forM_, mapM, forM, sequence)+import Control.Arrow (second)+import Control.DeepSeq+import Control.Monad.Except (throwError)+import Control.Monad.Reader+import Control.Monad.Writer hiding ((<>))  import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe+import Data.Set (Set) import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Monoid (Monoid, mempty, mappend)+import Data.Semigroup ((<>)) -import Numeric.IEEE+import GHC.Generics (Generic)  import qualified Agda.Utils.Haskell.Syntax as HS @@ -33,29 +42,30 @@ import Agda.Interaction.Options  import Agda.Syntax.Common-import Agda.Syntax.Fixity import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Names (namesIn) import qualified Agda.Syntax.Treeless as T import Agda.Syntax.Literal -import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Primitive (getBuiltinName) import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Pretty hiding ((<>)) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings +import Agda.Utils.FileName (isNewerThan) import Agda.Utils.Function import Agda.Utils.Functor+import Agda.Utils.Float import Agda.Utils.IO.Directory import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow, Pretty)+import Agda.Utils.Pretty (prettyShow, render) import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.String @@ -68,13 +78,13 @@ ghcBackend :: Backend ghcBackend = Backend ghcBackend' -ghcBackend' :: Backend' GHCOptions GHCOptions GHCModuleEnv IsMain [HS.Decl]+ghcBackend' :: Backend' GHCFlags GHCCompileEnv GHCModuleEnv GHCModule GHCDefinition ghcBackend' = Backend'   { backendName           = "GHC"   , backendVersion        = Nothing-  , options               = defaultGHCOptions+  , options               = defaultGHCFlags   , commandLineFlags      = ghcCommandLineFlags-  , isEnabled             = optGhcCompile+  , isEnabled             = flagGhcCompile   , preCompile            = ghcPreCompile   , postCompile           = ghcPostCompile   , preModule             = ghcPreModule@@ -84,22 +94,28 @@   , mayEraseType          = ghcMayEraseType   } ---- Options ---+--- Command-line flags --- -data GHCOptions = GHCOptions-  { optGhcCompile :: Bool-  , optGhcCallGhc :: Bool-  , optGhcFlags   :: [String]+data GHCFlags = GHCFlags+  { flagGhcCompile :: Bool+  , flagGhcCallGhc :: Bool+  , flagGhcBin     :: Maybe FilePath+    -- ^ Use the compiler at PATH instead of "ghc"+  , flagGhcFlags   :: [String]   }+  deriving Generic -defaultGHCOptions :: GHCOptions-defaultGHCOptions = GHCOptions-  { optGhcCompile = False-  , optGhcCallGhc = True-  , optGhcFlags   = []+instance NFData GHCFlags++defaultGHCFlags :: GHCFlags+defaultGHCFlags = GHCFlags+  { flagGhcCompile = False+  , flagGhcCallGhc = True+  , flagGhcBin     = Nothing+  , flagGhcFlags   = []   } -ghcCommandLineFlags :: [OptDescr (Flag GHCOptions)]+ghcCommandLineFlags :: [OptDescr (Flag GHCFlags)] ghcCommandLineFlags =     [ Option ['c']  ["compile", "ghc"] (NoArg enable)                     "compile program using the GHC backend"@@ -107,72 +123,173 @@                     "don't call GHC, just write the GHC Haskell files."     , Option []     ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG")                     "give the flag GHC-FLAG to GHC"+    , Option []     ["with-compiler"] (ReqArg withCompilerFlag "PATH")+                    "use the compiler available at PATH"     ]   where-    enable      o = pure o{ optGhcCompile = True }-    dontCallGHC o = pure o{ optGhcCallGhc = False }-    ghcFlag f   o = pure o{ optGhcFlags   = optGhcFlags o ++ [f] }+    enable      o = pure o{ flagGhcCompile = True }+    dontCallGHC o = pure o{ flagGhcCallGhc = False }+    ghcFlag f   o = pure o{ flagGhcFlags   = flagGhcFlags o ++ [f] } ---- Top-level compilation ---+withCompilerFlag :: FilePath -> Flag GHCFlags+withCompilerFlag fp o = case flagGhcBin o of+ Nothing -> pure o { flagGhcBin = Just fp }+ Just{}  -> throwError "only one compiler path allowed" -ghcPreCompile :: GHCOptions -> TCM GHCOptions-ghcPreCompile ghcOpts = do-  allowUnsolved <- optAllowUnsolved <$> pragmaOptions-  when allowUnsolved $ genericError $ "Unsolved meta variables are not allowed when compiling."-  return ghcOpts+--- Context types --- -ghcPostCompile :: GHCOptions -> IsMain -> Map ModuleName IsMain -> TCM ()-ghcPostCompile opts isMain mods = copyRTEModules >> callGHC opts isMain mods+-- | The options derived from @GHCFlags@ and other shared options.+data GHCOptions = GHCOptions+  { optGhcCallGhc    :: Bool+  , optGhcBin        :: FilePath+    -- ^ Use the compiler at PATH instead of "ghc"+  , optGhcFlags      :: [String]+  , optGhcCompileDir :: FilePath+  } ---- Module compilation ---+-- | Monads that can read @GHCOptions@+class Monad m => ReadGHCOpts m where+  askGhcOpts :: m GHCOptions --- | This environment is no longer used for anything.+instance Monad m => ReadGHCOpts (ReaderT GHCOptions m) where+  askGhcOpts = ask -type GHCModuleEnv = ()+data GHCCompileEnv = GHCCompileEnv+  { ghcCompileEnvOpts :: GHCOptions+  } +instance Monad m => ReadGHCOpts (ReaderT GHCCompileEnv m) where+  askGhcOpts = withReaderT ghcCompileEnvOpts askGhcOpts++-- | Module compilation environment, bundling the overall+--   backend session options along with the module's basic+--   readable properties.+data GHCModuleEnv = GHCModuleEnv+  { ghcModCompileEnv  :: GHCCompileEnv+  , ghcModHsModuleEnv :: HsModuleEnv+  }++instance Monad m => ReadGHCOpts (ReaderT GHCModuleEnv m) where+  askGhcOpts = withReaderT ghcModCompileEnv askGhcOpts++instance Monad m => ReadHsModuleEnv (ReaderT GHCModuleEnv m) where+  askHsModuleEnv = withReaderT ghcModHsModuleEnv askHsModuleEnv++data GHCModule = GHCModule+  { ghcModEnv                :: GHCModuleEnv+  , ghcModMainFuncs :: [MainFunctionDef]+  -- ^ The `main` function definition(s), if both the module is+  --   the @IsMain@ module (root/focused) and a suitable `main`+  --   function was defined.+  }++instance Monad m => ReadGHCOpts (ReaderT GHCModule m) where+  askGhcOpts = withReaderT ghcModEnv askGhcOpts++instance Monad m => ReadHsModuleEnv (ReaderT GHCModule m) where+  askHsModuleEnv = withReaderT ghcModEnv askHsModuleEnv++data GHCDefinition = GHCDefinition+  { ghcDefUsesFloat  :: UsesFloat+  , ghcDefDecls      :: [HS.Decl]+  , ghcDefDefinition :: Definition+  , ghcDefMainDef    :: Maybe MainFunctionDef+  , ghcDefImports    :: Set ModuleName+  }++--- Top-level compilation ---++ghcPreCompile :: GHCFlags -> TCM GHCCompileEnv+ghcPreCompile flags = do+  outDir <- compileDir+  let ghcOpts = GHCOptions+                { optGhcCallGhc    = flagGhcCallGhc flags+                , optGhcBin        = fromMaybe "ghc" (flagGhcBin flags)+                , optGhcFlags      = flagGhcFlags flags+                , optGhcCompileDir = outDir+                }+  return $ GHCCompileEnv ghcOpts++ghcPostCompile :: GHCCompileEnv -> IsMain -> Map ModuleName GHCModule -> TCM ()+ghcPostCompile _cenv _isMain mods = do+  -- FIXME: @curMName@ and @curIF@ are evil TCM state, but there does not appear to be+  --------- another way to retrieve the compilation root ("main" module or interaction focused).+  rootModuleName <- curMName+  rootModule <- ifJust (Map.lookup rootModuleName mods) pure+                $ genericError $ "Module " <> prettyShow rootModuleName <> " was not compiled!"+  flip runReaderT rootModule $ do+    copyRTEModules+    callGHC++--- Module compilation ---+ ghcPreModule-  :: GHCOptions+  :: GHCCompileEnv   -> IsMain      -- ^ Are we looking at the main module?   -> ModuleName-  -> FilePath    -- ^ Path to the @.agdai@ file.-  -> TCM (Recompile GHCModuleEnv IsMain)+  -> Maybe FilePath    -- ^ Path to the @.agdai@ file.+  -> TCM (Recompile GHCModuleEnv GHCModule)                  -- ^ Could we confirm the existence of a main function?-ghcPreModule _ isMain m ifile = ifM uptodate noComp yesComp+ghcPreModule cenv isMain m mifile = ifM uptodate noComp yesComp+    `runReaderT` GHCModuleEnv cenv (HsModuleEnv m (isMain == IsMain))   where-    uptodate = liftIO =<< isNewerThan <$> outFile_ <*> pure ifile+    uptodate = case mifile of+      Nothing -> pure False+      Just ifile -> liftIO =<< isNewerThan <$> curOutFile <*> pure ifile+    ifileDesc = fromMaybe "(memory)" mifile      noComp = do-      reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . show . A.mnameToConcrete =<< curMName-      Skip . hasMainFunction isMain <$> curIF+      reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . prettyShow . A.mnameToConcrete =<< curMName+      menv <- ask+      mainDefs <- ifM curIsMainModule+                         (mainFunctionDefs <$> curIF)+                         (pure [])+      return . Skip $ GHCModule menv mainDefs      yesComp = do-      m   <- show . A.mnameToConcrete <$> curMName-      out <- outFile_-      reportSLn "compile.ghc" 1 $ repl [m, ifile, out] "Compiling <<0>> in <<1>> to <<2>>"-      stImportedModules `setTCLens` Set.empty  -- we use stImportedModules to accumulate the required Haskell imports-      return (Recompile ())+      m   <- prettyShow . A.mnameToConcrete <$> curMName+      out <- curOutFile+      reportSLn "compile.ghc" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"+      asks Recompile  ghcPostModule-  :: GHCOptions+  :: GHCCompileEnv   -> GHCModuleEnv   -> IsMain        -- ^ Are we looking at the main module?   -> ModuleName-  -> [[HS.Decl]]   -- ^ Compiled module content.-  -> TCM IsMain    -- ^ Could we confirm the existence of a main function?-ghcPostModule _ _ isMain _ defs = do-  m      <- curHsMod-  imps   <- imports+  -> [GHCDefinition]   -- ^ Compiled module content.+  -> TCM GHCModule+ghcPostModule _cenv menv _isMain _moduleName ghcDefs = do+  builtinThings <- getsTC stBuiltinThings++  -- 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 imps = mazRTEFloatImport usedFloat ++ imports builtinThings usedModules defs++  i <- curIF+   -- Get content of FOREIGN pragmas.-  (headerPragmas, hsImps, code) <- foreignHaskell-  writeModule $ HS.Module m-    (map HS.OtherPragma headerPragmas)-    imps-    (map fakeDecl (hsImps ++ code) ++ concat defs)-  hasMainFunction isMain <$> curIF+  let (headerPragmas, hsImps, code) = foreignHaskell i -ghcCompileDef :: GHCOptions -> GHCModuleEnv -> IsMain -> Definition -> TCM [HS.Decl]-ghcCompileDef _ env isMain def = definition env isMain def+  flip runReaderT menv $ do+    hsModuleName <- curHsMod+    writeModule $ HS.Module+      hsModuleName+      (map HS.OtherPragma headerPragmas)+      imps+      (map fakeDecl (hsImps ++ code) ++ decls) +  return $ GHCModule menv mainDefs++ghcCompileDef :: GHCCompileEnv -> GHCModuleEnv -> IsMain -> Definition -> TCM GHCDefinition+ghcCompileDef _cenv menv _isMain def = do+  ((usesFloat, decls, mainFuncDef), (HsCompileState imps)) <- definition def `runHsCompileT` ghcModHsModuleEnv 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@@ -186,14 +303,8 @@  -- Compilation ------------------------------------------------------------ ------------------------------------------------------ imported modules---   I use stImportedModules in a non-standard way,---   accumulating in it what are acutally used in Misc.xqual-----------------------------------------------------imports :: TCM [HS.ImportDecl]-imports = (hsImps ++) <$> imps where+imports :: BuiltinThings PrimFun -> Set ModuleName -> [Definition] -> [HS.ImportDecl]+imports builtinThings usedModules defs = hsImps ++ imps where   hsImps :: [HS.ImportDecl]   hsImps = [unqualRTE, decl mazRTE] @@ -203,48 +314,70 @@                       | 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.PEqF,+  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]+              T.PITo64, T.P64ToI] -- Excludes T.PEqF, which is defined in MAlonzo.RTE.Float -  imps :: TCM [HS.ImportDecl]-  imps = List.map decl . uniq <$>-           ((++) <$> importsForPrim <*> (List.map mazMod <$> mnames))+  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 -  mnames :: TCM [ModuleName]-  mnames = Set.elems <$> useTC stImportedModules+  mnames :: [ModuleName]+  mnames = Set.elems usedModules    uniq :: [HS.ModuleName] -> [HS.ModuleName]   uniq = List.map head . List.group . List.sort +-- Should we import MAlonzo.RTE.Float+newtype UsesFloat = UsesFloat Bool deriving (Eq, Show)++pattern YesFloat :: UsesFloat+pattern YesFloat = UsesFloat True++pattern NoFloat :: UsesFloat+pattern NoFloat = UsesFloat False++instance Semigroup UsesFloat where+  UsesFloat a <> UsesFloat b = UsesFloat (a || b)++instance Monoid UsesFloat where+  mempty  = NoFloat+  mappend = (<>)++mazRTEFloatImport :: UsesFloat -> [HS.ImportDecl]+mazRTEFloatImport (UsesFloat b) = [ HS.ImportDecl mazRTEFloat True Nothing | b ]+ -------------------------------------------------- -- Main compiling clauses -------------------------------------------------- -definition :: GHCModuleEnv -> IsMain -> Definition -> TCM [HS.Decl]+definition :: Definition -> HsCompileM (UsesFloat, [HS.Decl], Maybe CheckedMainFunctionDef) -- ignore irrelevant definitions {- Andreas, 2012-10-02: Invariant no longer holds definition kit (Defn NonStrict _ _  _ _ _ _ _ _) = __IMPOSSIBLE__ -}-definition _env _isMain Defn{defArgInfo = info, defName = q} | not $ usableModality info = do+definition Defn{defArgInfo = info, defName = q} | not $ usableModality info = do   reportSDoc "compile.ghc.definition" 10 $     ("Not compiling" <+> prettyTCM q) <> "."-  return []-definition env isMain def@Defn{defName = q, defType = ty, theDef = d} = do+  return (mempty, mempty, Nothing)+definition def@Defn{defName = q, defType = ty, theDef = d} = do   reportSDoc "compile.ghc.definition" 10 $ vcat     [ ("Compiling" <+> prettyTCM q) <> ":"-    , nest 2 $ text (show d)+    , nest 2 $ text (prettyShow d)     ]-  pragma <- getHaskellPragma q+  pragma <- liftTCM $ getHaskellPragma q   mbool  <- getBuiltinName builtinBool   mlist  <- getBuiltinName builtinList+  mmaybe <- getBuiltinName builtinMaybe   minf   <- getBuiltinName builtinInf   mflat  <- getBuiltinName builtinFlat-  checkTypeOfMain isMain q def $ do-    infodecl q <$> case d of+  typeCheckedMainDef <- checkTypeOfMain def+  let mainDecl = maybeToList $ checkedMainDecl <$> typeCheckedMainDef+  let retDecls ds = return (mempty, ds)+  (uncurry (,,typeCheckedMainDef)) . second ((mainDecl ++) . infodecl q) <$>+    case d of        _ | Just (HsDefn r hs) <- pragma -> setCurrentRange r $           if Just q == mflat@@ -253,15 +386,14 @@           else do             -- Make sure we have imports for all names mentioned in the type.             hsty <- haskellType q-            ty   <- normalise ty-            sequence_ [ xqual x (HS.Ident "_") | x <- Set.toList (namesIn ty) ]+            mapM_ (`xqual` HS.Ident "_") (namesIn ty :: Set QName)            -- Check that the function isn't INLINE (since that will make this           -- definition pointless).             inline <- (^. funInline) . theDef <$> getConstInfo q             when inline $ warning $ UselessInline q -            return $ fbWithType hsty (fakeExp hs)+            retDecls $ fbWithType hsty (fakeExp hs)        -- Compiling Bool       Datatype{} | Just q == mbool -> do@@ -270,9 +402,9 @@         Just true  <- getBuiltinName builtinTrue         Just false <- getBuiltinName builtinFalse         cs <- mapM compiledcondecl [false, true]-        return $ [ compiledTypeSynonym q "Bool" 0-                 , HS.FunBind [HS.Match d [] (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] ++-                 cs+        retDecls $ [ compiledTypeSynonym q "Bool" 0+                   , HS.FunBind [HS.Match d [] (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] +++                   cs        -- Compiling List       Datatype{ dataPars = np } | Just q == mlist -> do@@ -285,10 +417,25 @@         Just cons <- getBuiltinName builtinCons         let vars f n = map (f . ihname "a") [0 .. n - 1]         cs <- mapM compiledcondecl [nil, cons]-        return $ [ HS.TypeDecl t (vars HS.UnkindedVar (np - 1)) (HS.FakeType "[]")-                 , HS.FunBind [HS.Match d (vars HS.PVar np) (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] ++-                 cs+        retDecls $ [ HS.TypeDecl t (vars HS.UnkindedVar (np - 1)) (HS.FakeType "[]")+                   , HS.FunBind [HS.Match d (vars HS.PVar np) (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] +++                   cs +      -- Compiling Maybe+      Datatype{ dataPars = np } | Just q == mmaybe -> do+        _ <- sequence_ [primNothing, primJust] -- Just to get the proper error for missing NOTHING/JUST+        caseMaybe pragma (return ()) $ \ p -> setCurrentRange p $ warning . GenericWarning =<< do+          fsep $ pwords "Ignoring GHC pragma for builtin maybe; they always compile to Haskell lists."+        let d = unqhname "d" q+            t = unqhname "T" q+        Just nothing <- getBuiltinName builtinNothing+        Just just    <- getBuiltinName builtinJust+        let vars f n = map (f . ihname "a") [0 .. n - 1]+        cs <- mapM compiledcondecl [nothing, just]+        retDecls $ [ HS.TypeDecl t (vars HS.UnkindedVar (np - 1)) (HS.FakeType "Maybe")+                   , HS.FunBind [HS.Match d (vars HS.PVar np) (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] +++                   cs+       -- Compiling Inf       _ | Just q == minf -> do         _ <- primSharp -- To get a proper error for missing SHARP.@@ -296,28 +443,36 @@         sharpC     <- compiledcondecl sharp         let d   = unqhname "d" q             err = "No term-level implementation of the INFINITY builtin."-        return $ [ compiledTypeSynonym q "MAlonzo.RTE.Infinity" 2-                 , HS.FunBind [HS.Match d [HS.PVar (ihname "a" 0)]-                     (HS.UnGuardedRhs (HS.FakeExp ("error " ++ show err)))-                     emptyBinds]-                 , sharpC-                 ]+        retDecls $ [ compiledTypeSynonym q "MAlonzo.RTE.Infinity" 2+                   , HS.FunBind [HS.Match d [HS.PVar (ihname "a" 0)]+                       (HS.UnGuardedRhs (HS.FakeExp ("error " ++ show err)))+                       emptyBinds]+                   , sharpC+                   ]        DataOrRecSig{} -> __IMPOSSIBLE__        Axiom{} -> do-        ar <- typeArity ty-        return $ [ compiledTypeSynonym q ty ar | Just (HsType r ty) <- [pragma] ] ++-                 fb axiomErr-      Primitive{ primName = s } -> fb <$> primBody s+        ar <- liftTCM $ typeArity ty+        retDecls $ [ compiledTypeSynonym q ty ar | Just (HsType r ty) <- [pragma] ] +++                   fb axiomErr+      Primitive{ primName = s } -> (mempty,) . fb <$> (liftTCM . primBody) s +      PrimitiveSort{ primName = s } -> retDecls []+       Function{} -> function pragma $ functionViaTreeless q -      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl, dataCons = cs }+      Datatype{ dataPathCons = _ : _ } -> do+        s <- render <$> prettyTCM q+        typeError $ NotImplemented $+          "Higher inductive types (" ++ s ++ ")"++      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl }         | Just hsdata@(HsData r ty hsCons) <- pragma -> setCurrentRange r $ do         reportSDoc "compile.ghc.definition" 40 $ hsep $           [ "Compiling data type with COMPILE pragma ...", pretty hsdata ]-        computeErasedConstructorArgs q+        liftTCM $ computeErasedConstructorArgs q+        cs <- liftTCM $ getNotErasedConstructors q         ccscov <- constructorCoverageCode q (np + ni) cs ty hsCons         cds <- mapM compiledcondecl cs         let result = concat $@@ -326,14 +481,14 @@               , cds               , ccscov               ]-        return result-      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl,-                dataCons = cs } -> do-        computeErasedConstructorArgs q+        retDecls result+      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl } -> do+        liftTCM $ computeErasedConstructorArgs q+        cs <- liftTCM $ getNotErasedConstructors q         cds <- mapM (flip condecl Inductive) cs-        return $ tvaldecl q Inductive (np + ni) cds cl-      Constructor{} -> return []-      GeneralizableVar{} -> return []+        retDecls $ tvaldecl q Inductive (np + ni) cds cl+      Constructor{} -> retDecls []+      GeneralizableVar{} -> retDecls []       Record{ recPars = np, recClause = cl, recConHead = con,               recInduction = ind } ->         let -- Non-recursive record types are treated as being@@ -342,21 +497,22 @@         in case pragma of           Just (HsData r ty hsCons) -> setCurrentRange r $ do             let cs = [conName con]-            computeErasedConstructorArgs q+            liftTCM $ computeErasedConstructorArgs q             ccscov <- constructorCoverageCode q np cs ty hsCons             cds <- mapM compiledcondecl cs-            return $+            retDecls $               tvaldecl q inductionKind np [] (Just __IMPOSSIBLE__) ++               [compiledTypeSynonym q ty np] ++ cds ++ ccscov           _ -> do-            computeErasedConstructorArgs q+            liftTCM $ computeErasedConstructorArgs q             cd <- condecl (conName con) inductionKind-            return $ tvaldecl q inductionKind (I.arity ty) [cd] cl+            retDecls $ tvaldecl q inductionKind (I.arity ty) [cd] cl       AbstractDefn{} -> __IMPOSSIBLE__   where-  function :: Maybe HaskellPragma -> TCM [HS.Decl] -> TCM [HS.Decl]+  function :: Maybe HaskellPragma -> HsCompileM (UsesFloat, [HS.Decl]) -> HsCompileM (UsesFloat, [HS.Decl])   function mhe fun = do-    ccls  <- mkwhere <$> fun+    (imp, defs) <- fun+    let ccls = mkwhere defs     mflat <- getBuiltinName builtinFlat     case mhe of       Just (HsExport r name) -> setCurrentRange r $@@ -370,14 +526,14 @@                def :: HS.Decl               def = HS.FunBind [HS.Match (HS.Ident name) [] (HS.UnGuardedRhs (hsCoerce $ hsVarUQ $ dname q)) emptyBinds]-          return ([tsig,def] ++ ccls)-      _ -> return ccls+          return (imp, [tsig,def] ++ ccls)+      _ -> return (imp, ccls) -  functionViaTreeless :: QName -> TCM [HS.Decl]-  functionViaTreeless q = caseMaybeM (toTreeless LazyEvaluation q) (pure []) $ \ treeless -> do+  functionViaTreeless :: QName -> HsCompileM (UsesFloat, [HS.Decl])+  functionViaTreeless q = caseMaybeM (liftTCM $ toTreeless LazyEvaluation q) (pure mempty) $ \ treeless -> do -    used <- getCompiledArgUse q-    let dostrip = any not used+    used <- fromMaybe [] <$> getCompiledArgUse q+    let dostrip = ArgUnused `elem` used      -- Compute the type approximation     def <- getConstInfo q@@ -386,10 +542,10 @@                  Function{ funProjection = Just Projection{ projIndex = i } } | i > 0 -> i - 1                  _ -> 0         argTypes  = drop pars argTypes0-        argTypesS = [ t | (t, True) <- zip argTypes (used ++ repeat True) ]+        argTypesS = filterUsed used argTypes -    e <- if dostrip then closedTerm (stripUnusedArguments used treeless)-                    else closedTerm treeless+    (e, useFloat) <- if dostrip then closedTerm (stripUnusedArguments used treeless)+                                else closedTerm treeless     let (ps, b) = lamView e         lamView e =           case e of@@ -403,13 +559,14 @@           in [tydecl f ts' t, funbind f ps b]      -- The definition of the non-stripped function-    (ps0, _) <- lamView <$> closedTerm (foldr ($) T.TErased $ replicate (length used) T.TLam)-    let b0 = foldl HS.App (hsVarUQ $ duname q) [ hsVarUQ x | (~(HS.PVar x), True) <- zip ps0 used ]+    (ps0, _) <- lamView <$> closedTerm_ (foldr ($) T.TErased $ replicate (length used) T.TLam)+    let b0 = foldl HS.App (hsVarUQ $ duname q) [ hsVarUQ x | (~(HS.PVar x), ArgUsed) <- zip ps0 used ] -    return $ if dostrip-      then tyfunbind (dname q) argTypes resType ps0 b0 ++-           tyfunbind (duname q) argTypesS resType ps b-      else tyfunbind (dname q) argTypes resType ps b+    return (useFloat,+            if dostrip+              then tyfunbind (dname q) argTypes resType ps0 b0 +++                   tyfunbind (duname q) argTypesS resType ps b+              else tyfunbind (dname q) argTypes resType ps b)    mkwhere :: [HS.Decl] -> [HS.Decl]   mkwhere (HS.FunBind [m0, HS.Match dn ps rhs emptyBinds] : fbs@(_:_)) =@@ -422,21 +579,21 @@    fbWithType :: HS.Type -> HS.Exp -> [HS.Decl]   fbWithType ty e =-    [ HS.TypeSig [unqhname "d" q] ty ] ++ fb e+    HS.TypeSig [unqhname "d" q] ty : fb e    fb :: HS.Exp -> [HS.Decl]   fb e  = [HS.FunBind [HS.Match (unqhname "d" q) []-                                (HS.UnGuardedRhs $ e) emptyBinds]]+                                (HS.UnGuardedRhs e) emptyBinds]]    axiomErr :: HS.Exp-  axiomErr = rtmError $ "postulate evaluated: " ++ prettyShow q+  axiomErr = rtmError $ Text.pack $ "postulate evaluated: " ++ prettyShow q -constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> TCM [HS.Decl]+constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> HsCompileM [HS.Decl] constructorCoverageCode q np cs hsTy hsCons = do-  checkConstructorCount q cs hsCons-  ifM (noCheckCover q) (return []) $ do+  liftTCM $ checkConstructorCount q cs hsCons+  ifM (liftTCM $ noCheckCover q) (return []) $ do     ccs <- List.concat <$> zipWithM checkConstructorType cs hsCons-    cov <- checkCover q hsTy np cs hsCons+    cov <- liftTCM $ checkCover q hsTy np cs hsCons     return $ ccs ++ cov  -- | Environment for naming of local variables.@@ -466,20 +623,27 @@ lookupIndex :: Int -> CCContext -> HS.Name lookupIndex i xs = fromMaybe __IMPOSSIBLE__ $ xs !!! i -type CC = ReaderT CCEnv TCM+-- | Constructor coverage monad transformer+type CCT m = ReaderT CCEnv (WriterT UsesFloat (HsCompileT m)) -freshNames :: Int -> ([HS.Name] -> CC a) -> CC a+-- | Constructor coverage monad+type CC = CCT TCM++liftCC :: Monad m => HsCompileT m a -> CCT m a+liftCC = lift . lift++freshNames :: Monad m => Int -> ([HS.Name] -> CCT m a) -> CCT m a freshNames n _ | n < 0 = __IMPOSSIBLE__ freshNames n cont = do   (xs, rest) <- splitAt n <$> view ccNameSupply   local (over ccNameSupply (const rest)) $ cont xs  -- | Introduce n variables into the context.-intros :: Int -> ([HS.Name] -> CC a) -> CC a+intros :: Monad m => Int -> ([HS.Name] -> CCT m a) -> CCT m a intros n cont = freshNames n $ \xs ->   local (over ccContext (reverse xs ++)) $ cont xs -checkConstructorType :: QName -> HaskellCode -> TCM [HS.Decl]+checkConstructorType :: QName -> HaskellCode -> HsCompileM [HS.Decl] checkConstructorType q hs = do   ty <- haskellType q   return [ HS.TypeSig [unqhname "check" q] ty@@ -487,7 +651,7 @@                                 (HS.UnGuardedRhs $ fakeExp hs) emptyBinds]          ] -checkCover :: QName -> HaskellType -> Nat -> [QName] -> [HaskellCode] -> TCM [HS.Decl]+checkCover :: HasConstInfo m => QName -> HaskellType -> Nat -> [QName] -> [HaskellCode] -> m [HS.Decl] checkCover q ty n cs hsCons = do   let tvs = [ "a" ++ show i | i <- [1..n] ]       makeClause c hsc = do@@ -503,16 +667,19 @@                                 (HS.UnGuardedRhs rhs) emptyBinds]          ] -closedTerm :: T.TTerm -> TCM HS.Exp+closedTerm_ :: T.TTerm -> HsCompileM HS.Exp+closedTerm_ t = fst <$> closedTerm t++closedTerm :: T.TTerm -> HsCompileM (HS.Exp, UsesFloat) closedTerm v = do-  v <- addCoercions v-  term v `runReaderT` initCCEnv+  v <- liftTCM $ addCoercions v+  runWriterT (term v `runReaderT` initCCEnv)  -- Translate case on bool to if mkIf :: T.TTerm -> CC T.TTerm mkIf t@(TCase e _ d [TACon c1 0 b1, TACon c2 0 b2]) | T.isUnreachable d = do-  mTrue  <- lift $ getBuiltinName builtinTrue-  mFalse <- lift $ getBuiltinName builtinFalse+  mTrue  <- liftCC $ getBuiltinName builtinTrue+  mFalse <- liftCC $ getBuiltinName builtinFalse   let isTrue  c = Just c == mTrue       isFalse c = Just c == mFalse   if | isTrue c1, isFalse c2 -> return $ T.tIfThenElse (TCoerce $ TVar e) b1 b2@@ -533,40 +700,36 @@     (T.TPrim T.PIf, [c, x, y]) -> coe <$> do HS.If <$> term c <*> term x <*> term y      (T.TDef f, ts) -> do-      used <- lift $ getCompiledArgUse f+      used <- liftCC $ fromMaybe [] <$> getCompiledArgUse f       -- #2248: no unused argument pruning for COMPILE'd functions-      isCompiled <- lift $ isJust <$> getHaskellPragma f+      isCompiled <- liftTCM $ isJust <$> getHaskellPragma f       let given   = length ts           needed  = length used           missing = drop given used-          notUsed = not-      if not isCompiled && any not used-        then if any notUsed missing then term (etaExpand (needed - given) tm0) else do-          f <- lift $ HS.Var <$> xhqn "du" f  -- use stripped function+      if not isCompiled && ArgUnused `elem` used+        then if ArgUnused `elem` missing then term (etaExpand (needed - given) tm0) else do+          f <- liftCC $ HS.Var <$> xhqn "du" f  -- use stripped function           -- Andreas, 2019-11-07, issue #4169.           -- Insert coercion unconditionally as erasure of arguments           -- that are matched upon might remove the unfolding of codomain types.           -- (Hard to explain, see test/Compiler/simple/Issue4169.)-          hsCoerce f `apps` [ t | (t, True) <- zip ts $ used ++ repeat True ]+          hsCoerce f `apps` filterUsed used ts         else do-          f <- lift $ HS.Var <$> xhqn "d" f  -- use original (non-stripped) function+          f <- liftCC $ HS.Var <$> xhqn "d" f  -- use original (non-stripped) function           coe f `apps` ts      (T.TCon c, ts) -> do-      erased  <- lift $ getErasedConArgs c+      erased  <- liftCC $ getErasedConArgs c       let missing = drop (length ts) erased           notErased = not-      case all notErased missing of-        -- If the constructor is fully applied or all missing arguments are retained,-        -- we can drop the erased arguments here, doing a complete job of dropping erased arguments.-        True  -> do-          f <- lift $ HS.Con <$> conhqn c-          hsCoerce f `apps` [ t | (t, False) <- zip ts erased ]-        -- Otherwise, we translate the eta-expanded constructor application.-        False -> do-          let n = length missing-          unless (n >= 1) __IMPOSSIBLE__  -- We will add at least on TLam, not getting a busy loop here.-          term $ etaExpand (length missing) tm0+      if all notErased missing+        then do+                f <- liftCC $ HS.Con <$> conhqn c+                hsCoerce f `apps` [ t | (t, False) <- zip ts erased ]+        else do+                let n = length missing+                unless (n >= 1) __IMPOSSIBLE__  -- We will add at least on TLam, not getting a busy loop here.+                term $ etaExpand (length missing) tm0      -- Other kind of application: fall back to apps.     (t, ts) -> noApplication t >>= \ t' -> coe t' `apps` ts@@ -597,13 +760,14 @@     let defAlt = HS.Alt HS.PWildCard (HS.UnGuardedRhs def') emptyBinds     return $ HS.Case (hsCoerce sc') (alts' ++ [defAlt]) -  T.TLit l    -> return $ literal l+  T.TLit l    -> literal l   T.TPrim p   -> return $ compilePrim p   T.TUnit     -> return $ HS.unit_con   T.TSort     -> return $ HS.unit_con   T.TErased   -> return $ hsVarUQ $ HS.Ident mazErasedName   T.TError e  -> return $ case e of     T.TUnreachable -> rtmUnreachableError+    T.TMeta s      -> rtmHole s  hsCoerce :: HS.Exp -> HS.Exp hsCoerce t = HS.App mazCoerce t@@ -616,23 +780,26 @@   case a of     T.TACon {T.aCon = c} -> do       intros (T.aArity a) $ \ xs -> do-        erased <- lift $ getErasedConArgs c-        nil  <- lift $ getBuiltinName builtinNil-        cons <- lift $ getBuiltinName builtinCons+        erased <- liftCC $ getErasedConArgs c+        nil  <- liftCC $ getBuiltinName builtinNil+        cons <- liftCC $ getBuiltinName builtinCons         hConNm <-           if | Just c == nil  -> return $ HS.UnQual $ HS.Ident "[]"              | Just c == cons -> return $ HS.UnQual $ HS.Symbol ":"-             | otherwise      -> lift $ conhqn c-        mkAlt (HS.PApp hConNm $ map HS.PVar [ x | (x, False) <- zip xs erased ])+             | otherwise      -> liftCC $ conhqn c+        mkAlt (HS.PApp hConNm $ [HS.PVar x | (x, False) <- zip xs erased])     T.TAGuard g b -> do       g <- term g       b <- term b       return $ HS.Alt HS.PWildCard                       (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier g] b])                       emptyBinds-    T.TALit { T.aLit = LitQName _ q } -> mkAlt (litqnamepat q)-    T.TALit { T.aLit = l@LitFloat{},   T.aBody = b } -> mkGuarded (treelessPrimName T.PEqF) (literal l) b-    T.TALit { T.aLit = LitString _ s , T.aBody = b } -> mkGuarded "(==)" (litString s) b+    T.TALit { T.aLit = LitQName q } -> mkAlt (litqnamepat q)+    T.TALit { T.aLit = l@LitFloat{}, T.aBody = b } -> do+      tell YesFloat+      l <- literal l+      mkGuarded (treelessPrimName T.PEqF) l b+    T.TALit { T.aLit = LitString s , T.aBody = b } -> mkGuarded "(==)" (litString s) b     T.TALit {} -> mkAlt (HS.PLit $ hslit $ T.aLit a)   where     mkGuarded eq lit b = do@@ -652,54 +819,50 @@         body' <- term $ T.aBody a         return $ HS.Alt pat (HS.UnGuardedRhs body') emptyBinds -literal :: Literal -> HS.Exp+literal :: forall m. Monad m => Literal -> CCT m HS.Exp literal l = case l of-  LitNat    _ _   -> typed "Integer"-  LitWord64 _ _   -> typed "MAlonzo.RTE.Word64"-  LitFloat  _ x   -> floatExp x "Double"-  LitQName  _ x   -> litqname x-  LitString _ s   -> litString s-  _               -> l'+  LitNat    _   -> return $ typed "Integer"+  LitWord64 _   -> return $ typed "MAlonzo.RTE.Word64"+  LitFloat  x   -> floatExp x "Double"+  LitQName  x   -> return $ litqname x+  LitString s   -> return $ litString s+  _             -> return $ l'   where     l'    = HS.Lit $ hslit l     typed = HS.ExpTypeSig l' . HS.TyCon . rtmQual      -- ASR (2016-09-14): See Issue #2169.     -- Ulf, 2016-09-28: and #2218.-    floatExp :: Double -> String -> HS.Exp+    floatExp :: Double -> String -> CCT m HS.Exp     floatExp x s-      | isNegativeZero x = rte "negativeZero"-      | isNegativeInf  x = rte "negativeInfinity"-      | isInfinite x     = rte "positiveInfinity"-      | isNegativeNaN x  = rte "negativeNaN"-      | isNaN x          = rte "positiveNaN"-      | otherwise        = typed s--    rte = HS.Var . HS.Qual mazRTE . HS.Ident--    isNegativeInf x = isInfinite x && x < 0.0-    isNegativeNaN x = isNaN x && not (identicalIEEE x (0.0 / 0.0))+      | isPosInf  x = rte "positiveInfinity"+      | isNegInf  x = rte "negativeInfinity"+      | isNegZero x = rte "negativeZero"+      | isNaN     x = rte "nan"+      | otherwise   = return $ typed s+      where+        rte s = do tell YesFloat; return $ HS.Var $ HS.Qual mazRTEFloat $ HS.Ident s  hslit :: Literal -> HS.Literal-hslit l = case l of LitNat    _ x -> HS.Int    x-                    LitWord64 _ x -> HS.Int    (fromIntegral x)-                    LitFloat  _ x -> HS.Frac   (toRational x)-                    LitChar   _ x -> HS.Char   x-                    LitQName  _ x -> __IMPOSSIBLE__-                    LitString _ _ -> __IMPOSSIBLE__-                    LitMeta{}     -> __IMPOSSIBLE__+hslit = \case+  LitNat    x -> HS.Int    x+  LitWord64 x -> HS.Int    (fromIntegral x)+  LitFloat  x -> HS.Frac   (toRational x)+  LitChar   x -> HS.Char   x+  LitQName  x -> __IMPOSSIBLE__+  LitString _ -> __IMPOSSIBLE__+  LitMeta{}   -> __IMPOSSIBLE__ -litString :: String -> HS.Exp-litString s =-  HS.Var (HS.Qual (HS.ModuleName "Data.Text") (HS.Ident "pack")) `HS.App`-    (HS.Lit $ HS.String s)+litString :: Text -> HS.Exp+litString s = HS.Ann (HS.Lit (HS.String s))+                     (HS.TyCon (HS.Qual (HS.ModuleName "Data.Text") (HS.Ident "Text")))  litqname :: QName -> HS.Exp litqname x =   rteCon "QName" `apps`   [ hsTypedInt n   , hsTypedInt m-  , HS.Lit $ HS.String $ prettyShow x+  , HS.Lit $ HS.String $ Text.pack $ prettyShow x   , rteCon "Fixity" `apps`     [ litAssoc (fixityAssoc fx)     , litPrec  (fixityLevel fx)@@ -708,7 +871,7 @@   where     apps = foldl HS.App     rteCon name = HS.Con $ HS.Qual mazRTE $ HS.Ident name-    NameId n m = nameId $ qnameName x+    NameId n (ModuleNameHash m) = nameId $ qnameName x     fx = theFixity $ nameFixity $ qnameName x      litAssoc NonAssoc   = rteCon "NonAssoc"@@ -725,9 +888,9 @@           , HS.PLit (HS.Int $ fromIntegral m)           , HS.PWildCard, HS.PWildCard ]   where-    NameId n m = nameId $ qnameName x+    NameId n (ModuleNameHash m) = nameId $ qnameName x -condecl :: QName -> Induction -> TCM HS.ConDecl+condecl :: QName -> Induction -> HsCompileM HS.ConDecl condecl q _ind = do   def <- getConstInfo q   let Constructor{ conPars = np, conErased = erased } = theDef def@@ -739,10 +902,10 @@                    ]   return $ HS.ConDecl (unqhname "C" q) argTypes -compiledcondecl :: QName -> TCM HS.Decl+compiledcondecl :: QName -> HsCompileM HS.Decl compiledcondecl q = do-  ar <- erasedArity q-  hsCon <- fromMaybe __IMPOSSIBLE__ <$> getHaskellConstructor q+  ar <- liftTCM $ erasedArity q+  hsCon <- liftTCM $ fromMaybe __IMPOSSIBLE__ <$> getHaskellConstructor q   let patVars = map (HS.PVar . ihname "a") [0 .. ar - 1]   return $ HS.PatSyn (HS.PApp (HS.UnQual $ unqhname "C" q) patVars) (HS.PApp (hsName hsCon) patVars) @@ -783,16 +946,19 @@ -- Writing out a haskell module -------------------------------------------------- -copyRTEModules :: TCM ()+type MonadGHCIO m = (MonadIO m, ReadGHCOpts m)++copyRTEModules :: MonadGHCIO m => m () copyRTEModules = do-  dataDir <- lift getDataDir+  dataDir <- liftIO getDataDir   let srcDir = dataDir </> "MAlonzo" </> "src"-  (lift . copyDirContent srcDir) =<< compileDir+  dstDir <- optGhcCompileDir <$> askGhcOpts+  liftIO $ copyDirContent srcDir dstDir -writeModule :: HS.Module -> TCM ()+writeModule :: MonadGHCIO m => HS.Module -> m () writeModule (HS.Module m ps imp ds) = do   -- Note that GHC assumes that sources use ASCII or UTF-8.-  out <- outFile m+  out <- snd <$> outFileAndDir m   liftIO $ UTF8.writeFile out $ (++ "\n") $ prettyPrint $     HS.Module m (p : ps) imp ds   where@@ -804,12 +970,12 @@         , "NoMonomorphismRestriction"         , "RankNTypes"         , "PatternSynonyms"+        , "OverloadedStrings"         ] --outFile' :: Pretty a => a -> TCM (FilePath, FilePath)-outFile' m = do-  mdir <- compileDir+outFileAndDir :: MonadGHCIO m => HS.ModuleName -> m (FilePath, FilePath)+outFileAndDir m = do+  mdir <- optGhcCompileDir <$> askGhcOpts   let (fdir, fn) = splitFileName $ repldot pathSeparator $                    prettyPrint m   let dir = mdir </> fdir@@ -819,25 +985,26 @@   where   repldot c = List.map $ \ c' -> if c' == '.' then c else c' -outFile :: HS.ModuleName -> TCM FilePath-outFile m = snd <$> outFile' m+curOutFileAndDir :: (MonadGHCIO m, ReadHsModuleEnv m) => m (FilePath, FilePath)+curOutFileAndDir = outFileAndDir =<< curHsMod -outFile_ :: TCM FilePath-outFile_ = outFile =<< curHsMod+curOutFile :: (MonadGHCIO m, ReadHsModuleEnv m) => m FilePath+curOutFile = snd <$> curOutFileAndDir -callGHC :: GHCOptions -> IsMain -> Map ModuleName IsMain -> TCM ()-callGHC opts modIsMain mods = do-  mdir    <- compileDir+callGHC :: ReaderT GHCModule TCM ()+callGHC = do+  opts    <- askGhcOpts   hsmod   <- prettyPrint <$> curHsMod-  agdaMod <- curMName+  agdaMod <- curAgdaMod   let outputName = case mnameToList agdaMod of         [] -> __IMPOSSIBLE__-        ms -> last ms-  (mdir, fp) <- outFile' =<< curHsMod+        m:ms -> last1 m ms+  (mdir, fp) <- curOutFileAndDir   let ghcopts = optGhcFlags opts -  let modIsReallyMain = fromMaybe __IMPOSSIBLE__ $ Map.lookup agdaMod mods-      isMain = mappend modIsMain modIsReallyMain  -- both need to be IsMain+  modIsMain <- curIsMainModule+  modHasMainFunc <- asks (not . null . ghcModMainFuncs)+  let isMain = modIsMain && modHasMainFunc  -- both need to be IsMain    -- Warn if no main function and not --no-main   when (modIsMain /= isMain) $@@ -846,11 +1013,11 @@    let overridableArgs =         [ "-O"] ++-        (if isMain == IsMain then ["-o", mdir </> show (nameConcrete outputName)] else []) +++        (if isMain then ["-o", mdir </> prettyShow (nameConcrete outputName)] else []) ++         [ "-Werror"]       otherArgs       =         [ "-i" ++ mdir] ++-        (if isMain == IsMain then ["-main-is", hsmod] else []) +++        (if isMain then ["-main-is", hsmod] else []) ++         [ fp         , "--make"         , "-fwarn-incomplete-patterns"@@ -858,10 +1025,10 @@         ]       args     = overridableArgs ++ ghcopts ++ otherArgs -  compiler <- fromMaybeM (pure "ghc") (optWithCompiler <$> commandLineOptions)+  let ghcBin = optGhcBin opts    -- Note: Some versions of GHC use stderr for progress reports. For   -- those versions of GHC we don't print any progress information   -- unless an error is encountered.   let doCall = optGhcCallGhc opts-  callCompiler doCall compiler args+  liftTCM $ callCompiler doCall ghcBin args

− src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot

@@ -1,8 +0,0 @@-module Agda.Compiler.MAlonzo.Compiler where--import qualified Agda.Utils.Haskell.Syntax as HS--import Agda.Syntax.Treeless (TTerm)-import Agda.TypeChecking.Monad (TCM)--closedTerm :: TTerm -> TCM HS.Exp

src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs view

@@ -9,6 +9,8 @@   ) where  import Control.Monad (zipWithM)+import Control.Monad.Except+-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) import Data.Maybe (fromMaybe) import Data.List (intercalate)@@ -17,7 +19,6 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive (getBuiltinName) import Agda.TypeChecking.Reduce@@ -30,9 +31,9 @@ import Agda.Compiler.MAlonzo.Pretty () --instance only  import qualified Agda.Utils.Haskell.Syntax as HS-import Agda.Utils.Except-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.List import Agda.Utils.Null+import Agda.Utils.Pretty (prettyShow)  import Agda.Utils.Impossible @@ -54,13 +55,18 @@ hsForall :: HS.Name -> HS.Type -> HS.Type hsForall x = HS.TyForall [HS.UnkindedVar x] +-- Issue #5207: From ghc-9.0 we have to be careful with nested foralls.+hsFun :: HS.Type -> HS.Type -> HS.Type+hsFun a (HS.TyForall vs b) = HS.TyForall vs $ hsFun a b+hsFun a b = HS.TyFun a b+ data WhyNot = NoPragmaFor QName             | WrongPragmaFor Range QName             | BadLambda Term             | BadMeta Term             | BadDontCare Term -type ToHs = ExceptT WhyNot TCM+type ToHs = ExceptT WhyNot HsCompileM  notAHaskellType :: Term -> WhyNot -> TCM a notAHaskellType top offender = typeError . GenericDocError =<< do@@ -71,8 +77,8 @@     reason (BadLambda        v) = pwords "the lambda term" ++ [prettyTCM v <> "."]     reason (BadMeta          v) = pwords "a meta variable" ++ [prettyTCM v <> "."]     reason (BadDontCare      v) = pwords "an erased term" ++ [prettyTCM v <> "."]-    reason (NoPragmaFor      x) = [prettyTCM x] ++ pwords "which does not have a COMPILE pragma."-    reason (WrongPragmaFor _ x) = [prettyTCM x] ++ pwords "which has the wrong kind of COMPILE pragma."+    reason (NoPragmaFor      x) = prettyTCM x : pwords "which does not have a COMPILE pragma."+    reason (WrongPragmaFor _ x) = prettyTCM x : pwords "which has the wrong kind of COMPILE pragma."      possibleFix BadLambda{}     = empty     possibleFix BadMeta{}       = empty@@ -95,25 +101,23 @@            , text ("for a suitable Haskell " ++ hsThing ++ ".")            ] -runToHs :: Term -> ToHs a -> TCM a-runToHs top m = either (notAHaskellType top) return =<< runExceptT m--liftE1 :: (forall a. m a -> m a) -> ExceptT e m a -> ExceptT e m a-liftE1 f = mkExceptT . f . runExceptT+runToHs :: Term -> ToHs a -> HsCompileM a+runToHs top m = either (liftTCM . notAHaskellType top) return =<< runExceptT m  liftE1' :: (forall b. (a -> m b) -> m b) -> (a -> ExceptT e m b) -> ExceptT e m b-liftE1' f k = mkExceptT (f (runExceptT . k))+liftE1' f k = ExceptT (f (runExceptT . k))  -- Only used in hsTypeApproximation below, and in that case we catch the error.-getHsType' :: QName -> TCM HS.Type+getHsType' :: QName -> HsCompileM HS.Type getHsType' q = runToHs (Def q []) (getHsType q)  getHsType :: QName -> ToHs HS.Type getHsType x = do   d <- liftTCM $ getHaskellPragma x   list <- liftTCM $ getBuiltinName builtinList+  mayb <- liftTCM $ getBuiltinName builtinMaybe   inf  <- liftTCM $ getBuiltinName builtinInf-  let namedType = liftTCM $ do+  let namedType = do         -- For these builtin types, the type name (xhqn ...) refers to the         -- generated, but unused, datatype and not the primitive type.         nat  <- getBuiltinName builtinNat@@ -121,9 +125,10 @@         bool <- getBuiltinName builtinBool         if  | Just x `elem` [nat, int] -> return $ hsCon "Integer"             | Just x == bool           -> return $ hsCon "Bool"-            | otherwise                -> hsCon . prettyShow <$> xhqn "T" x-  liftE1 (setCurrentRange d) $ case d of-    _ | Just x == list -> liftTCM $ hsCon . prettyShow <$> xhqn "T" x -- we ignore Haskell pragmas for List+            | otherwise                -> lift $ hsCon . prettyShow <$> xhqn "T" x+  mapExceptT (setCurrentRange d) $ case d of+    _ | Just x == list -> lift $ hsCon . prettyShow <$> xhqn "T" x -- we ignore Haskell pragmas for List+    _ | Just x == mayb -> lift $ hsCon . prettyShow <$> xhqn "T" x -- we ignore Haskell pragmas for Maybe     _ | Just x == inf  -> return $ hsQCon "MAlonzo.RTE" "Infinity"     Just HsDefn{}      -> throwError $ WrongPragmaFor (getRange d) x     Just HsType{}      -> namedType@@ -140,7 +145,7 @@       | c `elem` okChars = [c]       | otherwise        = "Z" ++ show (fromEnum c) -haskellType' :: Type -> TCM HS.Type+haskellType' :: Type -> HsCompileM HS.Type haskellType' t = runToHs (unEl t) (fromType t)   where     fromArgs = mapM (fromTerm . unArg)@@ -161,8 +166,8 @@           then do             hsA <- fromType (unDom a)             liftE1' (underAbstraction a b) $ \ b ->-              hsForall <$> getHsVar 0 <*> (HS.TyFun hsA <$> fromType b)-          else HS.TyFun <$> fromType (unDom a) <*> fromType (noabsApp __IMPOSSIBLE__ b)+              hsForall <$> getHsVar 0 <*> (hsFun hsA <$> fromType b)+          else hsFun <$> fromType (unDom a) <*> fromType (noabsApp __IMPOSSIBLE__ b)         Con c ci es -> do           let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es           hsApp <$> getHsType (conName c) <*> fromArgs args@@ -174,7 +179,7 @@         DontCare{} -> throwError (BadDontCare v)         Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s -haskellType :: QName -> TCM HS.Type+haskellType :: QName -> HsCompileM HS.Type haskellType q = do   def <- getConstInfo q   let (np, erased) =@@ -209,7 +214,7 @@              | otherwise = ""      genericDocError =<<-      fsep ([prettyTCM d] ++ pwords ("has " ++ show n +++      fsep (prettyTCM d : pwords ("has " ++ show n ++             " constructors, but " ++ only ++ n_forms_are ++ " given [" ++ unwords hsCons ++ "]"))   where     n  = length cs@@ -220,9 +225,10 @@ data PolyApprox = PolyApprox | NoPolyApprox   deriving (Eq) -hsTypeApproximation :: PolyApprox -> Int -> Type -> TCM HS.Type+hsTypeApproximation :: PolyApprox -> Int -> Type -> HsCompileM HS.Type hsTypeApproximation poly fv t = do   list <- getBuiltinName builtinList+  mayb <- getBuiltinName builtinMaybe   bool <- getBuiltinName builtinBool   int  <- getBuiltinName builtinInteger   nat  <- getBuiltinName builtinNat@@ -235,11 +241,13 @@         t <- unSpine <$> reduce t         case t of           Var i _ | poly == PolyApprox -> return $ tyVar n i-          Pi a b -> HS.TyFun <$> go n (unEl $ unDom a) <*> go (n + k) (unEl $ unAbs b)+          Pi a b -> hsFun <$> go n (unEl $ unDom a) <*> go (n + k) (unEl $ unAbs b)             where k = case b of Abs{} -> 1; NoAbs{} -> 0           Def q els-            | q `is` list, Apply t <- last ([Proj ProjSystem __IMPOSSIBLE__] ++ els)+            | q `is` list, Apply t <- last1 (Proj ProjSystem __IMPOSSIBLE__) els                         -> HS.TyApp (tyCon "[]") <$> go n (unArg t)+            | q `is` mayb, Apply t <- last1 (Proj ProjSystem __IMPOSSIBLE__) els+                        -> HS.TyApp (tyCon "Maybe") <$> go n (unArg t)             | q `is` bool -> return $ tyCon "Bool"             | q `is` int  -> return $ tyCon "Integer"             | q `is` nat  -> return $ tyCon "Integer"@@ -262,10 +270,10 @@ -- actually keep track of type applications in recursive functions, and -- generate parameterised datatypes. Otherwise we'll just coerce all type -- variables to `Any` at the first `unsafeCoerce`.-hsTelApproximation :: Type -> TCM ([HS.Type], HS.Type)+hsTelApproximation :: Type -> HsCompileM ([HS.Type], HS.Type) hsTelApproximation = hsTelApproximation' NoPolyApprox -hsTelApproximation' :: PolyApprox -> Type -> TCM ([HS.Type], HS.Type)+hsTelApproximation' :: PolyApprox -> Type -> HsCompileM ([HS.Type], HS.Type) hsTelApproximation' poly t = do   TelV tel res <- telView t   let args = map (snd . unDom) (telToList tel)

src/full/Agda/Compiler/MAlonzo/Misc.hs view

@@ -1,8 +1,26 @@+{-# LANGUAGE CPP #-}  module Agda.Compiler.MAlonzo.Misc where +import Control.Monad.Reader ( ask )+import Control.Monad.State ( modify )+import Control.Monad.Trans ( MonadTrans(lift) )+import Control.Monad.Trans.Except ( ExceptT )+import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Reader ( ReaderT(runReaderT) )+import Control.Monad.Trans.State ( StateT(runStateT) )+ import Data.Char+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T +#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+ import qualified Agda.Utils.Haskell.Syntax as HS  import Agda.Compiler.Common@@ -11,7 +29,6 @@ import Agda.Syntax.Internal  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin  import Agda.Utils.Pretty @@ -21,13 +38,68 @@ -- Setting up Interface before compile -------------------------------------------------- -curHsMod :: TCM HS.ModuleName-curHsMod = mazMod <$> curMName+data HsModuleEnv = HsModuleEnv+  { mazModuleName :: ModuleName+    -- ^ The name of the Agda module+  , mazIsMainModule :: Bool+  -- ^ Whether this is the compilation root and therefore should have the `main` function.+  --   This corresponds to the @IsMain@ flag provided to the backend,+  --   not necessarily whether the GHC module has a `main` function defined.+  } +-- | Monads that can produce an @HsModuleEnv@+class Monad m => ReadHsModuleEnv m where+  askHsModuleEnv :: m HsModuleEnv++  default askHsModuleEnv+    :: (MonadTrans t, Monad n, m ~ (t n), ReadHsModuleEnv n)+    => m HsModuleEnv+  askHsModuleEnv = lift askHsModuleEnv++instance Monad m => ReadHsModuleEnv (ReaderT HsModuleEnv m) where+  askHsModuleEnv = ask++instance ReadHsModuleEnv m => ReadHsModuleEnv (ExceptT e m)+instance ReadHsModuleEnv m => ReadHsModuleEnv (IdentityT m)+instance ReadHsModuleEnv m => ReadHsModuleEnv (MaybeT m)+instance ReadHsModuleEnv m => ReadHsModuleEnv (StateT s m)++newtype HsCompileState = HsCompileState+  { mazAccumlatedImports :: Set ModuleName+  } deriving (Eq, Semigroup, Monoid)++-- | Transformer adding read-only module info and a writable set of imported modules+type HsCompileT m = ReaderT HsModuleEnv (StateT HsCompileState m)++-- | The default compilation monad is the entire TCM (☹️) enriched with our state and module info+type HsCompileM = HsCompileT TCM++runHsCompileT' :: HsCompileT m a -> HsModuleEnv -> HsCompileState -> m (a, HsCompileState)+runHsCompileT' t e s = (flip runStateT s) . (flip runReaderT e) $ t++runHsCompileT :: HsCompileT m a -> HsModuleEnv -> m (a, HsCompileState)+runHsCompileT t e = runHsCompileT' t e mempty+ -------------------------------------------------- -- utilities for haskell names -------------------------------------------------- +-- | Whether the current module is expected to have the `main` function.+--   This corresponds to the @IsMain@ flag provided to the backend,+--   not necessarily whether the GHC module actually has a `main` function defined.+curIsMainModule :: ReadHsModuleEnv m => m Bool+curIsMainModule = mazIsMainModule <$> askHsModuleEnv++-- | This is the same value as @curMName@, but does not rely on the TCM's state.+--   (@curMName@ and co. should be removed, but the current @Backend@ interface+--   is not sufficient yet to allow that)+curAgdaMod :: ReadHsModuleEnv m => m ModuleName+curAgdaMod = mazModuleName <$> askHsModuleEnv++-- | Get the Haskell module name of the currently-focused Agda module+curHsMod :: ReadHsModuleEnv m => m HS.ModuleName+curHsMod = mazMod <$> curAgdaMod+ -- The following naming scheme seems to be used: -- -- * Types coming from Agda are named "T\<number\>".@@ -50,30 +122,34 @@    where idnum (NameId x _) = fromIntegral x  -- the toplevel module containing the given one-tlmodOf :: ModuleName -> TCM HS.ModuleName+tlmodOf :: ReadTCState m => ModuleName -> m HS.ModuleName tlmodOf = fmap mazMod . topLevelModuleName   -- qualify HS.Name n by the module of QName q, if necessary; -- accumulates the used module in stImportedModules at the same time.-xqual :: QName -> HS.Name -> TCM HS.QName-xqual q n = do m1 <- topLevelModuleName (qnameModule q)-               m2 <- curMName-               if m1 == m2 then return (HS.UnQual n)-                  else addImport m1 >> return (HS.Qual (mazMod m1) n)+xqual :: QName -> HS.Name -> HsCompileM HS.QName+xqual q n = do+  m1 <- topLevelModuleName (qnameModule q)+  m2 <- curAgdaMod+  if m1 == m2+    then return (HS.UnQual n)+    else do+      modify (HsCompileState . Set.insert m1 . mazAccumlatedImports)+      return (HS.Qual (mazMod m1) n) -xhqn :: String -> QName -> TCM HS.QName+xhqn :: String -> QName -> HsCompileM HS.QName xhqn s q = xqual q (unqhname s q)  hsName :: String -> HS.QName hsName s = HS.UnQual (HS.Ident s)  -- always use the original name for a constructor even when it's redefined.-conhqn :: QName -> TCM HS.QName+conhqn :: QName -> HsCompileM HS.QName conhqn q = xhqn "C" =<< canonicalName q  -- qualify name s by the module of builtin b-bltQual :: String -> String -> TCM HS.QName+bltQual :: String -> String -> HsCompileM HS.QName bltQual b s = do   Def q _ <- getBuiltin b   xqual q (HS.Ident s)@@ -144,9 +220,6 @@ mazMod :: ModuleName -> HS.ModuleName mazMod = mazMod' . prettyShow -mazerror :: String -> a-mazerror msg = error $ mazstr ++ ": " ++ msg- mazCoerceName :: String mazCoerceName = "coe" @@ -174,21 +247,30 @@ rtmUnreachableError :: HS.Exp rtmUnreachableError = mazUnreachableError +mazHole :: HS.Exp+mazHole = HS.Var $ HS.Qual mazRTE $ HS.Ident "mazHole"++rtmHole :: String -> HS.Exp+rtmHole s = mazHole `HS.App` HS.Lit (HS.String $ T.pack s)+ mazAnyType :: HS.Type mazAnyType = HS.TyCon (hsName mazAnyTypeName)  mazRTE :: HS.ModuleName mazRTE = HS.ModuleName "MAlonzo.RTE" +mazRTEFloat :: HS.ModuleName+mazRTEFloat = HS.ModuleName "MAlonzo.RTE.Float"+ rtmQual :: String -> HS.QName rtmQual = HS.UnQual . HS.Ident  rtmVar :: String -> HS.Exp rtmVar  = HS.Var . rtmQual -rtmError :: String -> HS.Exp+rtmError :: Text -> HS.Exp rtmError s = rtmVar "error" `HS.App`-             (HS.Lit $ HS.String $ "MAlonzo Runtime Error: " ++ s)+             HS.Lit (HS.String $ T.append "MAlonzo Runtime Error: " s)  unsafeCoerceMod :: HS.ModuleName unsafeCoerceMod = HS.ModuleName "Unsafe.Coerce"

src/full/Agda/Compiler/MAlonzo/Pragmas.hs view

@@ -4,7 +4,6 @@ import Data.Maybe import Data.Char import qualified Data.List as List-import Data.Traversable (traverse) import qualified Data.Map as Map import Text.ParserCombinators.ReadP @@ -96,7 +95,7 @@                                                     paren (sepBy (skipSpaces *> hsIdent) barP) <* skipSpaces     defnP   = HsDefn   r <$ wordsP ["="]         <* whitespace <*  notTypeOrData <*> hsCode -parseHaskellPragma :: CompilerPragma -> TCM HaskellPragma+parseHaskellPragma :: (MonadTCError m, MonadTrace m) => CompilerPragma -> m HaskellPragma parseHaskellPragma p = setCurrentRange p $   case parsePragma p of     Left err -> genericError err@@ -108,7 +107,7 @@   def <- getConstInfo q   setCurrentRange pragma $ pragma <$ sanityCheckPragma def pragma -sanityCheckPragma :: Definition -> Maybe HaskellPragma -> TCM ()+sanityCheckPragma :: (HasBuiltins m, MonadTCError m, MonadReduce m) => Definition -> Maybe HaskellPragma -> m () sanityCheckPragma _ Nothing = return () sanityCheckPragma def (Just HsDefn{}) =   case theDef def of@@ -151,19 +150,23 @@ --       occurrence! getHaskellConstructor :: QName -> TCM (Maybe HaskellCode) getHaskellConstructor c = do-  c     <- canonicalName c-  cDef  <- theDef <$> getConstInfo c-  true  <- getBuiltinName builtinTrue-  false <- getBuiltinName builtinFalse-  nil   <- getBuiltinName builtinNil-  cons  <- getBuiltinName builtinCons-  sharp <- getBuiltinName builtinSharp+  c       <- canonicalName c+  cDef    <- theDef <$> getConstInfo c+  true    <- getBuiltinName builtinTrue+  false   <- getBuiltinName builtinFalse+  nil     <- getBuiltinName builtinNil+  cons    <- getBuiltinName builtinCons+  nothing <- getBuiltinName builtinNothing+  just    <- getBuiltinName builtinJust+  sharp   <- getBuiltinName builtinSharp   case cDef of-    _ | Just c == true  -> return $ Just "True"-      | Just c == false -> return $ Just "False"-      | Just c == nil   -> return $ Just "[]"-      | Just c == cons  -> return $ Just "(:)"-      | Just c == sharp -> return $ Just "MAlonzo.RTE.Sharp"+    _ | Just c == true    -> return $ Just "True"+      | Just c == false   -> return $ Just "False"+      | Just c == nil     -> return $ Just "[]"+      | Just c == cons    -> return $ Just "(:)"+      | Just c == nothing -> return $ Just "Nothing"+      | Just c == just    -> return $ Just "Just"+      | Just c == sharp   -> return $ Just "MAlonzo.RTE.Sharp"     Constructor{conData = d} -> do       mp <- getHaskellPragma d       case mp of@@ -175,9 +178,9 @@  -- | Get content of @FOREIGN GHC@ pragmas, sorted by 'KindOfForeignCode': --   file header pragmas, import statements, rest.-foreignHaskell :: TCM ([String], [String], [String])+foreignHaskell :: Interface -> ([String], [String], [String]) foreignHaskell = partitionByKindOfForeignCode classifyForeign-    . map getCode . fromMaybe [] . Map.lookup ghcBackendName . iForeignCode <$> curIF+    . map getCode . fromMaybe [] . Map.lookup ghcBackendName . iForeignCode   where getCode (ForeignCode _ code) = code  -- | Classify @FOREIGN@ Haskell code.@@ -192,8 +195,8 @@ -- | Classify a @FOREIGN GHC@ declaration. classifyForeign :: String -> KindOfForeignCode classifyForeign s0 = case ltrim s0 of-  s | List.isPrefixOf "import " s -> ForeignImport-  s | List.isPrefixOf "{-#" s -> classifyPragma $ drop 3 s+  s | "import " `List.isPrefixOf` s -> ForeignImport+  s | "{-#" `List.isPrefixOf` s -> classifyPragma $ drop 3 s   _ -> ForeignOther  -- | Classify a Haskell pragma into whether it is a file header pragma or not.

src/full/Agda/Compiler/MAlonzo/Pretty.hs view

@@ -46,7 +46,7 @@   pretty (HS.IVar x) = pretty x  instance Pretty HS.Decl where-  pretty d = case d of+  pretty = \case     HS.TypeDecl f xs t ->       sep [ "type" <+> pretty f <+> fsep (map pretty xs) <+> "="           , nest 2 $ pretty t ]@@ -160,6 +160,11 @@       HS.InfixApp a qop b -> mparens (pr > 0) $         sep [ prettyPrec 1 a             , pretty qop <+> prettyPrec 1 b ]+      HS.Ann e ty -> mparens (pr > 0) $+        sep [ prettyPrec 1 e+            , "::"+            , prettyPrec 1 ty+            ]       HS.App{} -> mparens (pr > 9) $         sep [ prettyPrec 9 f             , nest 2 $ fsep $ map (prettyPrec 10) es ]

src/full/Agda/Compiler/MAlonzo/Primitives.hs view

@@ -1,21 +1,24 @@  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 qualified Data.Map as Map+import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap import Data.Maybe+import qualified Data.Text as T  import Agda.Compiler.Common import Agda.Compiler.ToTreeless-import {-# SOURCE #-} Agda.Compiler.MAlonzo.Compiler (closedTerm) import Agda.Compiler.MAlonzo.Misc import Agda.Compiler.MAlonzo.Pretty import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Treeless import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Primitive import Agda.TypeChecking.Reduce import Agda.TypeChecking.Pretty@@ -27,10 +30,17 @@  import Agda.Utils.Impossible +newtype MainFunctionDef = MainFunctionDef Definition++data CheckedMainFunctionDef = CheckedMainFunctionDef+  { checkedMainDef :: MainFunctionDef+  , checkedMainDecl :: HS.Decl+  }+ -- Andreas, 2019-04-29, issue #3731: exclude certain kinds of names, like constructors. -- TODO: Also only consider top-level definition (not buried inside a module).-isMainFunction :: QName -> Defn -> Bool-isMainFunction q = \case+asMainFunctionDef :: Definition -> Maybe MainFunctionDef+asMainFunctionDef d = case (theDef d) of     Axiom{}                             -> perhaps     Function{ funProjection = Nothing } -> perhaps     Function{ funProjection = Just{}  } -> no@@ -41,32 +51,32 @@     Record{}                            -> no     Constructor{}                       -> no     Primitive{}                         -> no+    PrimitiveSort{}                     -> no   where-  perhaps = "main" == prettyShow (nameConcrete $ qnameName q)  -- ignores the qualification!?-  no      = False+  isNamedMain = "main" == prettyShow (nameConcrete . qnameName . defName $ d)  -- ignores the qualification!?+  perhaps | isNamedMain = Just $ MainFunctionDef d+          | otherwise   = no+  no                    = Nothing --- | Check for "main" function, but only in the main module.-hasMainFunction-  :: IsMain    -- ^ Are we looking at the main module?-  -> Interface -- ^ The module.-  -> IsMain    -- ^ Did we find a "main" function?-hasMainFunction NotMain _ = NotMain-hasMainFunction IsMain i-  | List.any (\ (x, def) -> isMainFunction x $ theDef def) names = IsMain-  | otherwise = NotMain+mainFunctionDefs :: Interface -> [MainFunctionDef]+mainFunctionDefs i = catMaybes $ asMainFunctionDef <$> defs   where-    names = HMap.toList $ iSignature i ^. sigDefinitions+    defs = HMap.elems $ iSignature i ^. sigDefinitions  -- | Check that the main function has type IO a, for some a.-checkTypeOfMain :: IsMain -> QName -> Definition -> TCM [HS.Decl] -> TCM [HS.Decl]-checkTypeOfMain NotMain q def ret = ret-checkTypeOfMain  IsMain q def ret-  | not (isMainFunction q $ theDef def) = ret-  | otherwise = do+checkTypeOfMain :: Definition -> HsCompileM (Maybe CheckedMainFunctionDef)+checkTypeOfMain def = runMaybeT $ do+  -- Only indicate main functions in the main module.+  isMainModule <- curIsMainModule+  mainDef <- MaybeT $ pure $ if isMainModule then asMainFunctionDef def else Nothing+  liftTCM $ checkTypeOfMain' mainDef++checkTypeOfMain' :: MainFunctionDef -> TCM CheckedMainFunctionDef+checkTypeOfMain' m@(MainFunctionDef def) = CheckedMainFunctionDef m <$> do     Def io _ <- primIO-    ty <- normalise $ defType def+    ty <- reduce $ defType def     case unEl ty of-      Def d _ | d == io -> (mainAlias :) <$> ret+      Def d _ | d == io -> return mainAlias       _                 -> do         err <- fsep $           pwords "The type of main should be" ++@@ -75,74 +85,83 @@   where     mainAlias = HS.FunBind [HS.Match mainLHS [] mainRHS emptyBinds ]     mainLHS   = HS.Ident "main"-    mainRHS   = HS.UnGuardedRhs $ HS.App mazCoerce (HS.Var $ HS.UnQual $ unqhname "d" q)+    mainRHS   = HS.UnGuardedRhs $ HS.App mazCoerce (HS.Var $ HS.UnQual $ unqhname "d" $ defName def)  treelessPrimName :: TPrim -> String treelessPrimName p =   case p of-    PQuot -> "quotInt"-    PRem  -> "remInt"-    PSub  -> "subInt"-    PAdd  -> "addInt"-    PMul  -> "mulInt"-    PGeq  -> "geqInt"-    PLt   -> "ltInt"-    PEqI  -> "eqInt"+    PQuot   -> "quotInt"+    PRem    -> "remInt"+    PSub    -> "subInt"+    PAdd    -> "addInt"+    PMul    -> "mulInt"+    PGeq    -> "geqInt"+    PLt     -> "ltInt"+    PEqI    -> "eqInt"     PQuot64 -> "quot64"     PRem64  -> "rem64"     PSub64  -> "sub64"     PAdd64  -> "add64"     PMul64  -> "mul64"     PLt64   -> "lt64"-    PEq64  -> "eq64"-    PITo64 -> "word64FromNat"-    P64ToI -> "word64ToNat"-    PEqF  -> "eqFloat"+    PEq64   -> "eq64"+    PITo64  -> "word64FromNat"+    P64ToI  -> "word64ToNat"+    PEqF    -> "MAlonzo.RTE.Float.doubleDenotEq"     -- MAlonzo uses literal patterns, so we don't need equality for the other primitive types-    PEqC  -> __IMPOSSIBLE__-    PEqS  -> __IMPOSSIBLE__-    PEqQ  -> __IMPOSSIBLE__-    PSeq  -> "seq"+    PEqC    -> __IMPOSSIBLE__+    PEqS    -> __IMPOSSIBLE__+    PEqQ    -> __IMPOSSIBLE__+    PSeq    -> "seq"     -- primitives only used by GuardsToPrims transformation, which MAlonzo doesn't use-    PIf   -> __IMPOSSIBLE__+    PIf     -> __IMPOSSIBLE__  -- | Haskell modules to be imported for BUILT-INs-importsForPrim :: TCM [HS.ModuleName]-importsForPrim =-  fmap (++ [HS.ModuleName "Data.Text"]) $-  xForPrim $-  List.map (\(s, ms) -> (s, return (List.map HS.ModuleName ms))) $-  [ "CHAR"              |-> ["Data.Char"]-  , "primIsAlpha"       |-> ["Data.Char"]-  , "primIsAscii"       |-> ["Data.Char"]-  , "primIsDigit"       |-> ["Data.Char"]-  , "primIsHexDigit"    |-> ["Data.Char"]-  , "primIsLatin1"      |-> ["Data.Char"]-  , "primIsLower"       |-> ["Data.Char"]-  , "primIsPrint"       |-> ["Data.Char"]-  , "primIsSpace"       |-> ["Data.Char"]-  , "primToLower"       |-> ["Data.Char"]-  , "primToUpper"       |-> ["Data.Char"]-  ]-  where (|->) = (,)+importsForPrim :: BuiltinThings PrimFun -> [Definition] -> [HS.ModuleName]+importsForPrim builtinThings defs = xForPrim table builtinThings defs ++ [HS.ModuleName "Data.Text"]+  where+  table = Map.fromList $ second (HS.ModuleName <$>) <$>+    [ "CHAR"                       |-> ["Data.Char"]+    , "primIsAlpha"                |-> ["Data.Char"]+    , "primIsAscii"                |-> ["Data.Char"]+    , "primIsDigit"                |-> ["Data.Char"]+    , "primIsHexDigit"             |-> ["Data.Char"]+    , "primIsLatin1"               |-> ["Data.Char"]+    , "primIsLower"                |-> ["Data.Char"]+    , "primIsPrint"                |-> ["Data.Char"]+    , "primIsSpace"                |-> ["Data.Char"]+    , "primToLower"                |-> ["Data.Char"]+    , "primToUpper"                |-> ["Data.Char"]+    , "primFloatInequality"        |-> ["MAlonzo.RTE.Float"]+    , "primFloatEquality"          |-> ["MAlonzo.RTE.Float"]+    , "primFloatLess"              |-> ["MAlonzo.RTE.Float"]+    , "primFloatIsSafeInteger"     |-> ["MAlonzo.RTE.Float"]+    , "primFloatToWord64"          |-> ["MAlonzo.RTE.Float"]+    , "primFloatRound"             |-> ["MAlonzo.RTE.Float"]+    , "primFloatFloor"             |-> ["MAlonzo.RTE.Float"]+    , "primFloatCeiling"           |-> ["MAlonzo.RTE.Float"]+    , "primFloatToRatio"           |-> ["MAlonzo.RTE.Float"]+    , "primRatioToFloat"           |-> ["MAlonzo.RTE.Float"]+    , "primFloatDecode"            |-> ["MAlonzo.RTE.Float"]+    , "primFloatEncode"            |-> ["MAlonzo.RTE.Float"]+    ]+  (|->) = (,)  -------------- -xForPrim :: [(String, TCM [a])] -> TCM [a]-xForPrim table = do-  qs <- HMap.keys <$> curDefs-  bs <- Map.toList <$> getsTC stBuiltinThings-  let getName (Builtin (Def q _))    = q-      getName (Builtin (Con q _ _))  = conName q-      getName (Builtin (Lam _ b))    = getName (Builtin $ unAbs b)-      getName (Builtin _)            = __IMPOSSIBLE__+xForPrim :: Map.Map String [a] -> BuiltinThings PrimFun -> [Definition] -> [a]+xForPrim table builtinThings defs =+  let qs = Set.fromList $ defName <$> defs+      bs = Map.toList builtinThings+      getName (Builtin t)            = getPrimName t       getName (Prim (PrimFun q _ _)) = q-  concat <$> sequence [ fromMaybe (return []) $ List.lookup s table-                        | (s, def) <- bs, getName def `elem` qs ]+  in+  concat [ fromMaybe [] $ Map.lookup s table+         | (s, def) <- bs, getName def `Set.member` qs ]   -- | Definition bodies for primitive functions-primBody :: String -> TCM HS.Exp+primBody :: MonadTCError m => String -> m HS.Exp primBody s = maybe unimplemented (fromRight (hsVarUQ . HS.Ident) <$>) $              List.lookup s $   [@@ -165,6 +184,7 @@    -- Sorts   , "primSetOmega"    |-> return "()"+  , "primStrictSet"   |-> return "\\ _ -> ()"    -- Natural number functions   , "primNatPlus"      |-> binNat "(+)"@@ -182,35 +202,47 @@   , "primWord64ToNatInjective" |-> return "erased"    -- Floating point functions-  , "primNatToFloat"        |-> return "(fromIntegral :: Integer -> Double)"-  , "primFloatPlus"         |-> return "((+)          :: Double -> Double -> Double)"-  , "primFloatMinus"        |-> return "((-)          :: Double -> Double -> Double)"-  , "primFloatTimes"        |-> return "((*)          :: Double -> Double -> Double)"-  , "primFloatNegate"       |-> return "(negate       :: Double -> Double)"-  , "primFloatDiv"          |-> return "((/)          :: Double -> Double -> Double)"-  -- ASR (2016-09-14). We use bitwise equality for comparing Double-  -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove-  -- a contradiction (see Issue #2169).-  , "primFloatEquality"          |-> return "MAlonzo.RTE.eqFloat"-  , "primFloatLess"              |-> return "MAlonzo.RTE.ltFloat"-  , "primFloatNumericalEquality" |-> return "MAlonzo.RTE.eqNumFloat"-  , "primFloatNumericalLess"     |-> return "MAlonzo.RTE.ltNumFloat"-  , "primFloatSqrt"         |-> return "(sqrt :: Double -> Double)"-  , "primRound"             |-> return "(round . MAlonzo.RTE.normaliseNaN :: Double -> Integer)"-  , "primFloor"             |-> return "(floor . MAlonzo.RTE.normaliseNaN :: Double -> Integer)"-  , "primCeiling"           |-> return "(ceiling . MAlonzo.RTE.normaliseNaN :: Double -> Integer)"-  , "primExp"               |-> return "(exp :: Double -> Double)"-  , "primLog"               |-> return "(log :: Double -> Double)"-  , "primSin"               |-> return "(sin :: Double -> Double)"-  , "primCos"               |-> return "(cos :: Double -> Double)"-  , "primTan"               |-> return "(tan :: Double -> Double)"-  , "primASin"              |-> return "(asin :: Double -> Double)"-  , "primACos"              |-> return "(acos :: Double -> Double)"-  , "primATan"              |-> return "(atan :: Double -> Double)"-  , "primATan2"             |-> return "(atan2 :: Double -> Double -> Double)"-  , "primShowFloat"         |-> return "(Data.Text.pack . show :: Double -> Data.Text.Text)"-  , "primFloatToWord64"     |-> return "MAlonzo.RTE.doubleToWord64"+  , "primFloatEquality"          |-> return "MAlonzo.RTE.Float.doubleEq"+  , "primFloatInequality"        |-> return "MAlonzo.RTE.Float.doubleLe"+  , "primFloatLess"              |-> return "MAlonzo.RTE.Float.doubleLt"+  , "primFloatIsInfinite"        |-> return "(isInfinite :: Double -> Bool)"+  , "primFloatIsNaN"             |-> return "(isNaN :: Double -> Bool)"+  , "primFloatIsNegativeZero"    |-> return "(isNegativeZero :: Double -> Bool)"+  , "primFloatIsSafeInteger"     |-> return "MAlonzo.RTE.Float.isSafeInteger"+  , "primFloatToWord64"          |-> return "MAlonzo.RTE.Float.doubleToWord64"   , "primFloatToWord64Injective" |-> return "erased"+  , "primNatToFloat"             |-> return "(MAlonzo.RTE.Float.intToDouble :: Integer -> Double)"+  , "primIntToFloat"             |-> return "(MAlonzo.RTE.Float.intToDouble :: Integer -> Double)"+  , "primFloatRound"             |-> return "MAlonzo.RTE.Float.doubleRound"+  , "primFloatFloor"             |-> return "MAlonzo.RTE.Float.doubleFloor"+  , "primFloatCeiling"           |-> return "MAlonzo.RTE.Float.doubleCeiling"+  , "primFloatToRatio"           |-> return "MAlonzo.RTE.Float.doubleToRatio"+  , "primRatioToFloat"           |-> return "MAlonzo.RTE.Float.ratioToDouble"+  , "primFloatDecode"            |-> return "MAlonzo.RTE.Float.doubleDecode"+  , "primFloatEncode"            |-> return "MAlonzo.RTE.Float.doubleEncode"+  , "primShowFloat"              |-> return "(Data.Text.pack . show :: Double -> Data.Text.Text)"+  , "primFloatPlus"              |-> return "MAlonzo.RTE.Float.doublePlus"+  , "primFloatMinus"             |-> return "MAlonzo.RTE.Float.doubleMinus"+  , "primFloatTimes"             |-> return "MAlonzo.RTE.Float.doubleTimes"+  , "primFloatNegate"            |-> return "MAlonzo.RTE.Float.doubleNegate"+  , "primFloatDiv"               |-> return "MAlonzo.RTE.Float.doubleDiv"+  , "primFloatPow"               |-> return "MAlonzo.RTE.Float.doublePow"+  , "primFloatSqrt"              |-> return "MAlonzo.RTE.Float.doubleSqrt"+  , "primFloatExp"               |-> return "MAlonzo.RTE.Float.doubleExp"+  , "primFloatLog"               |-> return "MAlonzo.RTE.Float.doubleLog"+  , "primFloatSin"               |-> return "MAlonzo.RTE.Float.doubleSin"+  , "primFloatCos"               |-> return "MAlonzo.RTE.Float.doubleCos"+  , "primFloatTan"               |-> return "MAlonzo.RTE.Float.doubleTan"+  , "primFloatASin"              |-> return "MAlonzo.RTE.Float.doubleASin"+  , "primFloatACos"              |-> return "MAlonzo.RTE.Float.doubleACos"+  , "primFloatATan"              |-> return "MAlonzo.RTE.Float.doubleATan"+  , "primFloatATan2"             |-> return "MAlonzo.RTE.Float.doubleATan2"+  , "primFloatSinh"              |-> return "MAlonzo.RTE.Float.doubleSinh"+  , "primFloatCosh"              |-> return "MAlonzo.RTE.Float.doubleCosh"+  , "primFloatTanh"              |-> return "MAlonzo.RTE.Float.doubleTanh"+  , "primFloatASinh"             |-> return "MAlonzo.RTE.Float.doubleASinh"+  , "primFloatACosh"             |-> return "MAlonzo.RTE.Float.doubleACosh"+  , "primFloatATanh"             |-> return "MAlonzo.RTE.Float.doubleATanh"    -- Character functions   , "primCharEquality"   |-> rel "(==)" "Char"@@ -225,17 +257,19 @@   , "primToUpper"        |-> return "Data.Char.toUpper"   , "primToLower"        |-> return "Data.Char.toLower"   , "primCharToNat" |-> return "(fromIntegral . fromEnum :: Char -> Integer)"-  , "primNatToChar" |-> return "(toEnum . fromIntegral :: Integer -> Char)"+  , "primNatToChar" |-> return "MAlonzo.RTE.natToChar"   , "primShowChar"  |-> return "(Data.Text.pack . show :: Char -> Data.Text.Text)"   , "primCharToNatInjective" |-> return "erased"    -- String functions+  , "primStringUncons"   |-> return "Data.Text.uncons"   , "primStringToList"   |-> return "Data.Text.unpack"   , "primStringFromList" |-> return "Data.Text.pack"   , "primStringAppend"   |-> binAsis "Data.Text.append" "Data.Text.Text"   , "primStringEquality" |-> rel "(==)" "Data.Text.Text"   , "primShowString"     |-> return "(Data.Text.pack . show :: Data.Text.Text -> Data.Text.Text)"   , "primStringToListInjective" |-> return "erased"+  , "primStringFromListInjective" |-> return "erased"    -- Reflection   , "primQNameEquality"   |-> rel "(==)" "MAlonzo.RTE.QName"@@ -255,19 +289,10 @@   , "primForceLemma" |-> return "erased"    -- Erase-  , ("primEraseEquality", Right <$> do-       refl <- primRefl-       let erase = hLam "a" $ hLam "A" $ hLam "x" $ hLam "y" $ nLam "eq" refl-       closedTerm =<< closedTermToTreeless LazyEvaluation erase-    )+  , "primEraseEquality" |-> return "erased"   ]   where   x |-> s = (x, Left <$> s)-  bin blt op ty from to = do-    from' <- bltQual' blt from-    to'   <- bltQual' blt to-    return $ repl [op, opty ty, from', to'] $-               "\\ x y -> <<3>> ((<<0>> :: <<1>>) (<<2>> x) (<<2>> y))"   binNat  op = return $ repl [op] "(<<0>> :: Integer -> Integer -> Integer)"   binNat4 op = return $ repl [op] "(<<0>> :: Integer -> Integer -> Integer -> Integer -> Integer)"   binAsis op ty = return $ repl [op, opty ty] $ "((<<0>>) :: <<1>>)"@@ -279,24 +304,15 @@       "(<<0>> :: Integer -> Integer -> Bool)"   rel op ty  = rel' "" op ty   opty t = t ++ "->" ++ t ++ "->" ++ t-  axiom_prims = ["primIMin","primIMax","primINeg","primPartial","primPartialP","primPFrom1","primPOr","primComp"]-  unimplemented | s `List.elem` axiom_prims = return $ rtmError $ "primitive with no body evaluated: " ++ s-                | otherwise = typeError $ NotImplemented s+  unimplemented = typeError $ NotImplemented s    hLam x t = Lam (setHiding Hidden defaultArgInfo) (Abs x t)   nLam x t = Lam (setHiding NotHidden defaultArgInfo) (Abs x t) -noCheckCover :: QName -> TCM Bool+noCheckCover :: (HasBuiltins m, MonadReduce m) => QName -> m Bool noCheckCover q = (||) <$> isBuiltin q builtinNat <*> isBuiltin q builtinInteger  ---------------------- --pconName :: String -> TCM String-pconName s = toS =<< getBuiltin s where-  toS (Con q _ _) = prettyPrint <$> conhqn (conName q)-  toS (Lam _ t) = toS (unAbs t)-  toS _ = mazerror $ "pconName" ++ s--bltQual' :: String -> String -> TCM String+bltQual' :: String -> String -> HsCompileM String bltQual' b s = prettyPrint <$> bltQual b s

src/full/Agda/Compiler/ToTreeless.hs view

@@ -9,14 +9,14 @@  import Data.Maybe import Data.Map (Map)-import qualified Data.Map as Map-import Data.Traversable (traverse)+import qualified Data.Map  as Map+import qualified Data.List as List  import Agda.Syntax.Common import Agda.Syntax.Internal as I import Agda.Syntax.Literal import qualified Agda.Syntax.Treeless as C-import Agda.Syntax.Treeless (TTerm, EvaluationStrategy)+import Agda.Syntax.Treeless (TTerm, EvaluationStrategy, ArgUsage(..))  import Agda.TypeChecking.CompiledClause as CC import qualified Agda.TypeChecking.CompiledClause.Compile as CC@@ -102,9 +102,9 @@   reportSDoc "treeless.opt.converted" (30 + v) $ "-- converted" $$ pbody body   body <- runPipeline eval q (compilerPipeline v q) body   used <- usedArguments q body-  when (any not used) $+  when (ArgUnused `elem` used) $     reportSDoc "treeless.opt.unused" (30 + v) $-      "-- used args:" <+> hsep [ if u then text [x] else "_" | (x, u) <- zip ['a'..] used ] $$+      "-- used args:" <+> hsep [ if u == ArgUsed then text [x] else "_" | (x, u) <- zip ['a'..] used ] $$       pbody' "[stripped]" (stripUnusedArguments used body)   reportSDoc "treeless.opt.final" (20 + v) $ pbody body   setTreeless q body@@ -128,8 +128,12 @@ compilerPipeline :: Int -> QName -> Pipeline compilerPipeline v q =   Sequential-    [ compilerPass "simpl"   (35 + v) "simplification"      $ const simplifyTTerm-    , compilerPass "builtin" (30 + v) "builtin translation" $ const translateBuiltins+    -- 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@@ -176,7 +180,9 @@ alwaysInline q = do   def <- theDef <$> getConstInfo q   pure $ case def of  -- always inline with functions and pattern lambdas-    Function{} -> isJust (funExtLam def) || isJust (funWith def)+    Function{funClauses = cs} -> (isJust (funExtLam def) && not recursive) || isJust (funWith def)+            where+              recursive = any (fromMaybe True . clauseRecursive) cs     _ -> False  -- | Initial environment for expression generation.@@ -223,12 +229,20 @@ casetree :: CC.CompiledClauses -> CC C.TTerm casetree cc = do   case cc of-    CC.Fail -> return C.tUnreachable+    CC.Fail xs -> withContextSize (length xs) $ return C.tUnreachable     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)-      substTerm v+      cxt <- asks ccCxt+      v' <- substTerm v+      reportS "treeless.convert.casetree" 40 $+        [ "-- casetree, calling substTerm:"+        , "--   cxt =" <+> prettyPure cxt+        , "--   v   =" <+> prettyPure v+        , "--   v'  =" <+> prettyPure v'+        ]+      return v'     CC.Case _ (CC.Branches True _ _ _ Just{} _ _) -> __IMPOSSIBLE__       -- Andreas, 2016-06-03, issue #1986: Ulf: "no catch-all for copatterns!"       -- lift $ do@@ -236,25 +250,31 @@       --     "Not yet implemented: compilation of copattern matching with catch-all clause"     CC.Case (Arg _ n) (CC.Branches True conBrs _ _ Nothing _ _) -> lambdasUpTo n $ do       mkRecord =<< traverse casetree (CC.content <$> conBrs)-    CC.Case (Arg _ n) (CC.Branches False conBrs etaBr litBrs catchAll _ lazy) -> lambdasUpTo (n + 1) $ do+    CC.Case (Arg i n) (CC.Branches False conBrs etaBr litBrs catchAll _ lazy) -> lambdasUpTo (n + 1) $ do                     -- We can treat eta-matches as regular matches here.       let conBrs' = Map.union conBrs $ Map.fromList $ map (first conName) $ maybeToList etaBr       if Map.null conBrs' && Map.null litBrs then do         -- there are no branches, just return default         updateCatchAll catchAll fromCatchAll       else do-        caseTy <- case (Map.keys conBrs', Map.keys litBrs) of-              ((c:_), []) -> do-                c' <- lift (canonicalName c)-                dtNm <- conData . theDef <$> lift (getConstInfo c')-                return $ C.CTData dtNm-              ([], (LitChar _ _):_)  -> return C.CTChar-              ([], (LitString _ _):_) -> return C.CTString-              ([], (LitFloat _ _):_) -> return C.CTFloat-              ([], (LitQName _ _):_) -> return C.CTQName-              _ -> __IMPOSSIBLE__+        -- Get the type of the scrutinee.+        caseTy <-+          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 (getQuantity i) conData+                _ -> go cs+              go [] = __IMPOSSIBLE__+            ([], LitChar   _ : _) -> return C.CTChar+            ([], LitString _ : _) -> return C.CTString+            ([], LitFloat  _ : _) -> return C.CTFloat+            ([], LitQName  _ : _) -> return C.CTQName+            _ -> __IMPOSSIBLE__+         updateCatchAll catchAll $ do-          x <- lookupLevel n <$> asks ccCxt+          x <- asks (lookupLevel n . ccCxt)           def <- fromCatchAll           let caseInfo = C.CaseInfo { caseType = caseTy, caseLazy = lazy }           C.TCase x caseInfo def <$> do@@ -265,7 +285,7 @@     -- normally, Agda should make sure that a pattern match is total,     -- so we set the default to unreachable if no default has been provided.     fromCatchAll :: CC C.TTerm-    fromCatchAll = maybe C.tUnreachable C.TVar <$> asks ccCatchAll+    fromCatchAll = asks (maybe C.tUnreachable C.TVar . ccCatchAll)  commonArity :: CC.CompiledClauses -> Int commonArity cc =@@ -275,13 +295,13 @@   where     arities cxt (Case (Arg _ x) (Branches False cons eta lits def _ _)) =       concatMap (wArities cxt') (Map.elems cons) ++-      concatMap (wArities cxt') (map snd $ maybeToList eta) +++      concatMap ((wArities cxt') . snd) (maybeToList eta) ++       concatMap (wArities cxt' . WithArity 0) (Map.elems lits) ++       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 _   Fail        = []+    arities cxt (Fail xs)   = [max cxt (length xs)]       wArities cxt (WithArity k c) = map (\ x -> x - k + 1) $ arities (cxt - 1 + k) c@@ -290,7 +310,13 @@ updateCatchAll Nothing cont = cont updateCatchAll (Just cc) cont = do   def <- casetree cc-  local (\e -> e { ccCatchAll = Just 0, ccCxt = shift 1 (ccCxt e) }) $ do+  cxt <- asks ccCxt+  reportS "treeless.convert.lambdas" 40 $+    [ "-- updateCatchAll:"+    , "--   cxt =" <+> prettyPure cxt+    , "--   def =" <+> prettyPure def+    ]+  local (\ e -> e { ccCatchAll = Just 0, ccCxt = shift 1 cxt }) $ do     C.mkLet def <$> cont  -- | Shrinks or grows the context to the given size.@@ -298,42 +324,109 @@ -- MUST NOT be used inside `cont`. withContextSize :: Int -> CC C.TTerm -> CC C.TTerm withContextSize n cont = do-  diff <- (n -) . length <$> asks ccCxt--  if diff <= 0-  then do+  diff <- asks (((n -) . length) . ccCxt)+  if diff >= 1 then createLambdas diff cont else do     let diff' = -diff-    local (\e -> e { ccCxt = shift diff . drop diff' $ ccCxt e }) $+    cxt <- -- shift diff .+       -- Andreas, 2021-04-10, issue #5288+       -- The @shift diff@ is wrong, since we are returning to the original+       -- context from @cont@, and then we would have to reverse+       -- the effect of @shift diff@.+       -- We need to make sure that the result of @cont@ make sense+       -- in the **present** context, not the changed context+       -- where it is constructed.+       --+       -- Ulf, 2021-04-12, https://github.com/agda/agda/pull/5311/files#r611452551+       --+       -- This looks correct, but I can't quite follow the explanation. Here's my understanding:+       --+       -- We are building a `TTerm` case tree from `CompiledClauses`. In order+       -- to be able to match we bind all variables we'll need in a top-level+       -- lambda `λ a b c d → ..` (say). As we compute the `TTerm` we keep a+       -- context (list) of `TTerm` deBruijn indices for each `CompiledClause`+       -- variable. This is a renaming from the *source* context of the+       -- `CompiledClause` to the *target* context of the `TTerm`.+       --+       -- After some pattern matching we might have+       -- ```+       -- λ a b c d →+       --   case c of+       --     e :: f → {cxt = [d, f, e, b, a]}+       -- ```+       -- Now, what's causing the problems here is that `CompiledClauses` can be+       -- underapplied, so you might have matched on a variable only to find+       -- that in the catch-all the variable you matched on is bound in a lambda+       -- in the right-hand side! Extending the example, we might have+       -- `CompiledClauses` looking like this:+       -- ```+       -- case 2 of+       --   _::_ → done[d, f, e, b, a] ...+       --   _    → done[b, a] (λ c d → ...)+       -- ```+       -- When we get to the catch-all, the context will be `[d, c, b, a]` but+       -- the right-hand side is only expecting `a` and `b` to be bound. What we+       -- need to do is compile the right-hand side and then apply it to the+       -- variables `c` and `d` that we already bound. This is what+       -- `withContextSize` does.+       --+       -- Crucially (and this is where the bug was), we are not changing the+       -- target context, only the source context (we want a `TTerm` that makes+       -- sense at this point). This means that the correct move is to drop the+       -- entries for the additional source variables, but not change what+       -- target variables the remaining source variables map to. Hence, `drop`+       -- but no `shift`.+       --+       drop diff' <$> asks ccCxt+    local (\ e -> e { ccCxt = cxt }) $ do+      reportS "treeless.convert.lambdas" 40 $+        [ "-- withContextSize:"+        , "--   n   =" <+> prettyPure n+        , "--   diff=" <+> prettyPure diff+        , "--   cxt =" <+> prettyPure cxt+        ]       cont <&> (`C.mkTApp` map C.TVar (downFrom diff'))-  else do-    local (\e -> e { ccCxt = [0..(diff - 1)] ++ shift diff (ccCxt e)}) $ do-      createLambdas diff <$> do-        cont-  where createLambdas :: Int -> C.TTerm -> C.TTerm-        createLambdas 0 cont' = cont'-        createLambdas i cont' | i > 0 = C.TLam (createLambdas (i - 1) cont')-        createLambdas _ _ = __IMPOSSIBLE__ +-- | Prepend the given positive number of lambdas.+-- Does not update the catchAll expression,+-- the catchAll expression must be updated separately (or not be used).+createLambdas :: Int -> CC C.TTerm -> CC C.TTerm+createLambdas diff cont = do+  unless (diff >= 1) __IMPOSSIBLE__+  cxt <- ([0 .. diff-1] ++) . shift diff <$> asks ccCxt+  local (\ e -> e { ccCxt = cxt }) $ do+    reportS "treeless.convert.lambdas" 40 $+      [ "-- createLambdas:"+      , "--   diff =" <+> prettyPure diff+      , "--   cxt  =" <+> prettyPure cxt+      ]+    -- Prepend diff lambdas+    cont <&> \ t -> List.iterate C.TLam t !! diff+ -- | Adds lambdas until the context has at least the given size. -- Updates the catchAll expression to take the additional lambdas into account. lambdasUpTo :: Int -> CC C.TTerm -> CC C.TTerm lambdasUpTo n cont = do-  diff <- (n -) . length <$> asks ccCxt+  diff <- asks (((n -) . length) . ccCxt)    if diff <= 0 then cont -- no new lambdas needed   else do-    catchAll <- asks ccCatchAll--    withContextSize n $ do-      case catchAll of-        Just catchAll' -> do+    createLambdas diff $ do+      asks ccCatchAll >>= \case+        Just catchAll -> do+          cxt <- asks ccCxt+          reportS "treeless.convert.lambdas" 40 $+            [ "lambdasUpTo: n =" <+> (text . show) n+            , "  diff         =" <+> (text . show) n+            , "  catchAll     =" <+> prettyPure catchAll+            , "  ccCxt        =" <+> prettyPure cxt+            ]           -- the catch all doesn't know about the additional lambdas, so just directly           -- apply it again to the newly introduced lambda arguments.           -- we also bind the catch all to a let, to avoid code duplication           local (\e -> e { ccCatchAll = Just 0-                         , ccCxt = shift 1 (ccCxt e)}) $ do+                         , ccCxt = shift 1 cxt }) $ do             let catchAllArgs = map C.TVar $ downFrom diff-            C.mkLet (C.mkTApp (C.TVar $ catchAll' + diff) catchAllArgs)+            C.mkLet (C.mkTApp (C.TVar $ catchAll + diff) catchAllArgs)               <$> cont         Nothing -> cont @@ -373,7 +466,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 _ind xs <- conSrcCon . theDef <$> (getConstInfo =<< canonicalName . I.conName =<< recConFromProj p1)+  I.ConHead c IsRecord{} _ind 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)@@ -399,12 +492,12 @@ substTerm term = normaliseStatic term >>= \ term ->   case I.unSpine $ etaContractErased term of     I.Var ind es -> do-      ind' <- lookupIndex ind <$> asks ccCxt+      ind' <- asks (lookupIndex ind . ccCxt)       let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es       C.mkTApp (C.TVar ind') <$> substArgs args     I.Lam _ ab ->       C.TLam <$>-        local (\e -> e { ccCxt = 0 : (shift 1 $ ccCxt e) })+        local (\e -> e { ccCxt = 0 : shift 1 (ccCxt e) })           (substTerm $ I.unAbs ab)     I.Lit l -> return $ C.TLit l     I.Level _ -> return C.TUnit@@ -417,7 +510,7 @@         C.mkTApp (C.TCon c') <$> substArgs args     I.Pi _ _ -> return C.TUnit     I.Sort _  -> return C.TSort-    I.MetaV _ _ -> __IMPOSSIBLE__   -- we don't compiled if unsolved metas+    I.MetaV x _ -> return $ C.TError $ C.TMeta $ prettyShow x     I.DontCare _ -> return C.TErased     I.Dummy{} -> __IMPOSSIBLE__ @@ -486,10 +579,11 @@       fun@Function{}         | fun ^. funInline -> doinline eval         | otherwise -> do-        used <- lift $ getCompiledArgUse q-        let substUsed False _   = pure C.TErased-            substUsed True  arg = substArg arg-        C.mkTApp (C.TDef q) <$> sequence [ substUsed u arg | (arg, u) <- zip vs $ used ++ repeat True ]+        -- If ArgUsage hasn't been computed yet, we assume all arguments are used.+        used <- lift $ fromMaybe [] <$> getCompiledArgUse q+        let substUsed _   ArgUnused = pure C.TErased+            substUsed arg ArgUsed   = substArg arg+        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

src/full/Agda/Compiler/Treeless/Builtin.hs view

@@ -17,14 +17,12 @@ module Agda.Compiler.Treeless.Builtin (translateBuiltins) where  import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Position import Agda.Syntax.Treeless import Agda.Syntax.Literal  import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin  import Agda.Compiler.Treeless.Subst () --instance only import Agda.Utils.Impossible@@ -77,7 +75,7 @@ transform :: BuiltinKit -> TTerm -> TTerm transform BuiltinKit{..} = tr   where-    tr t = case t of+    tr = \case        TCon c | isZero c   -> tInt 0              | isSuc c    -> TLam (tPlusK 1 (TVar 0))@@ -99,7 +97,7 @@        TApp (TCon s) [e] | isSuc s ->         case tr e of-          TLit (LitNat r n) -> tInt (n + 1)+          TLit (LitNat n) -> tInt (n + 1)           e | Just (i, e) <- plusKView e -> tPlusK (i + 1) e           e                 -> tPlusK 1 e @@ -107,21 +105,21 @@         | isPos c    -> tr e         | isNegSuc c ->         case tr e of-          TLit (LitNat _ n) -> tInt (-n - 1)+          TLit (LitNat n) -> tInt (-n - 1)           e | Just (i, e) <- plusKView e -> tNegPlusK (i + 1) e           e -> tNegPlusK 1 e        TCase e t d bs -> TCase e (inferCaseType t bs) (tr d) $ concatMap trAlt bs         where-          trAlt b = case b of-            TACon c 0 b | isZero c -> [TALit (LitNat noRange 0) (tr b)]+          trAlt = \case+            TACon c 0 b | isZero c -> [TALit (LitNat 0) (tr b)]             TACon c 1 b | isSuc c  ->               case tr b of                 -- Collapse nested n+k patterns                 TCase 0 _ d bs' -> map sucBranch bs' ++ [nPlusKAlt 1 d]                 b -> [nPlusKAlt 1 b]               where-                sucBranch (TALit (LitNat r i) b) = TALit (LitNat r (i + 1)) $ TLet (tInt i) b+                sucBranch (TALit (LitNat i) b) = TALit (LitNat (i + 1)) $ TLet (tInt i) b                 sucBranch alt | Just (k, b) <- nPlusKView alt =                   nPlusKAlt (k + 1) $ TLet (tOp PAdd (TVar 0) (tInt 1)) $                     applySubst ([TVar 1, TVar 0] ++# wkS 2 idS) b@@ -129,9 +127,6 @@                  nPlusKAlt k b = TAGuard (tOp PGeq (TVar e) (tInt k)) $                                 TLet (tOp PSub (TVar e) (tInt k)) b--                str err = compactS err [Nothing]-             TACon c 1 b | isPos c ->               case tr b of                 -- collapse nested nat patterns@@ -139,7 +134,7 @@                 b -> [posAlt  b]               where                 -- subst scrutinee for the pos argument-                sub :: Subst TTerm a => a -> a+                sub :: SubstWith TTerm a => a -> a                 sub = applySubst (TVar e :# IdS)                  posAlt b = TAGuard (tOp PGeq (TVar e) (tInt 0)) $ sub b@@ -153,26 +148,25 @@                 body b   = TLet (tNegPlusK 1 (TVar e)) b                 negAlt b = TAGuard (tOp PLt (TVar e) (tInt 0)) $ body b -                negsucBranch (TALit (LitNat r i) b) = TALit (LitNat r (-i - 1)) $ 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                 negsucBranch _ = __IMPOSSIBLE__ -             TACon c a b -> [TACon c a (tr b)]             TALit l b   -> [TALit l (tr b)]             TAGuard g b -> [TAGuard (tr g) (tr b)] -      TVar{}    -> t-      TDef{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TLit{}    -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+      t@TVar{}    -> t+      t@TDef{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TLit{}    -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t        TCoerce a -> TCoerce (tr a) @@ -187,7 +181,7 @@       | 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/EliminateDefaults.hs view

@@ -16,8 +16,9 @@ eliminateCaseDefaults = tr   where     tr :: TTerm -> TCM TTerm-    tr t = case t of-      TCase sc ct@CaseInfo{caseType = CTData qn} def alts | not (isUnreachable def) -> do+    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@@ -30,25 +31,23 @@         return $ TLet def $ TCase (sc + 1) ct tUnreachable alts'       TCase sc ct def alts -> TCase sc ct <$> tr def <*> mapM trAlt alts -      TVar{}    -> tt-      TDef{}    -> tt-      TCon{}    -> tt-      TPrim{}   -> tt-      TLit{}    -> tt-      TUnit{}   -> tt-      TSort{}   -> tt-      TErased{} -> tt-      TError{}  -> tt+      t@TVar{}    -> return t+      t@TDef{}    -> return t+      t@TCon{}    -> return t+      t@TPrim{}   -> return t+      t@TLit{}    -> return t+      t@TUnit{}   -> return t+      t@TSort{}   -> return t+      t@TErased{} -> return t+      t@TError{}  -> return t        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 -      where tt = return t-     trAlt :: TAlt -> TCM TAlt-    trAlt a = case a of+    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

src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs view

@@ -3,12 +3,10 @@  import Data.Maybe -import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Treeless import Agda.Syntax.Literal  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Primitive  import Agda.Utils.Impossible@@ -28,7 +26,7 @@ transform kit = tr   where     tr :: TTerm -> TTerm-    tr t = case t of+    tr = \case       TCase sc t def alts | caseType t `elem` [CTChar, CTString, CTQName, CTNat, CTInt, CTFloat] ->         foldr litAlt (tr def) alts         where@@ -39,37 +37,39 @@               (tr body)               cont           litAlt _ _ = __IMPOSSIBLE__-      TCase sc t@CaseInfo{caseType = CTData dt} def alts -> TCase sc t (tr def) (map trAlt alts)+      TCase sc t@CaseInfo{caseType = CTData _ dt} def alts ->+        TCase sc t (tr def) (map trAlt alts)         where-          trAlt a = case a of+          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)       TCase _ _ _ _ -> __IMPOSSIBLE__ -      TVar{}    -> t-      TDef{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TLit{}    -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+      t@TVar{}    -> t+      t@TDef{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TLit{}    -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t        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) -    isCaseOn (CTData dt) xs = dt `elem` mapMaybe ($ kit) xs+    -- TODO:: Defined but not used+    isCaseOn (CTData _ dt) xs = dt `elem` mapMaybe ($ kit) xs     isCaseOn _ _ = False      eqFromLit :: Literal -> TPrim-    eqFromLit x = case x of-      LitNat _ _     -> PEqI-      LitFloat _ _   -> PEqF-      LitString _ _  -> PEqS-      LitChar _ _    -> PEqC-      LitQName _ _   -> PEqQ-      _              -> __IMPOSSIBLE__+    eqFromLit = \case+      LitNat _     -> PEqI+      LitFloat _   -> PEqF+      LitString _  -> PEqS+      LitChar _    -> PEqC+      LitQName _   -> PEqQ+      _ -> __IMPOSSIBLE__

src/full/Agda/Compiler/Treeless/Erase.hs view

@@ -11,17 +11,16 @@ import Control.Monad.State 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-import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Position import Agda.Syntax.Treeless import Agda.Syntax.Literal  import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad as I-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Telescope import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Pretty@@ -65,7 +64,7 @@ -- | Takes the name of the data/record type. computeErasedConstructorArgs :: QName -> TCM () computeErasedConstructorArgs d = do-  cs <- getConstructors d+  cs <- getNotErasedConstructors d   runE $ mapM_ getFunInfo cs  eraseTerms :: QName -> EvaluationStrategy -> TTerm -> TCM TTerm@@ -128,7 +127,7 @@      tLet e b       | freeIn 0 b = TLet e b-      | otherwise  = strengthen __IMPOSSIBLE__ b+      | otherwise  = strengthen impossible b      tApp f []                  = f     tApp TErased _             = TErased@@ -154,7 +153,7 @@     eraseRel r t | erasable r = pure TErased                  | otherwise  = erase t -    eraseAlt a = case a of+    eraseAlt = \case       TALit l b   -> TALit l   <$> erase b       TACon c a b -> do         rs <- map erasable . fst <$> getFunInfo c@@ -165,8 +164,19 @@ -- | Doesn't have any type information (other than the name of the data type), --   so we can't do better than checking if all constructors are present. pruneUnreachable :: Int -> CaseType -> TTerm -> [TAlt] -> E (TTerm, [TAlt])-pruneUnreachable _ (CTData q) d bs = do-  cs <- lift $ getConstructors q+pruneUnreachable _ (CTData quantity q) d bs' = do+  -- In an erased setting erased constructors are not treated+  -- specially.+  cs <- lift $+        if hasQuantity0 quantity+        then getConstructors q+        else getNotErasedConstructors q+  let bs | hasQuantity0 quantity = bs'+         | otherwise             =+           flip filter bs' $ \case+             a@TACon{} -> (aCon a) `elem` cs+             TAGuard{} -> True+             TALit{}   -> True   let complete =length cs == length [ b | b@TACon{} <- bs ]   let d' | complete  = tUnreachable          | otherwise = d@@ -176,11 +186,11 @@ pruneUnreachable _ _ d bs = pure (d, bs)  -- These are the guards we generate for Int/Nat pattern matching-pattern Below :: Range -> Int -> Integer -> TTerm-pattern Below r x n = TApp (TPrim PLt)  [TVar x, TLit (LitNat r n)]+pattern Below :: Int -> Integer -> TTerm+pattern Below x n = TApp (TPrim PLt)  [TVar x, TLit (LitNat n)] -pattern Above :: Range -> Int -> Integer -> TTerm-pattern Above r x n = TApp (TPrim PGeq) [TVar x, TLit (LitNat r n)]+pattern Above :: Int -> Integer -> TTerm+pattern Above x n = TApp (TPrim PGeq) [TVar x, TLit (LitNat n)]  -- | Strip unreachable clauses (replace by tUnreachable for the default). --   Fourth argument is the set of ints covered so far.@@ -192,9 +202,9 @@       | otherwise            = (d, [])     go (b : bs) cover =       case b of-        TAGuard (Below _ y n) _ | x == y -> rec (IntSet.below n)-        TAGuard (Above _ y n) _ | x == y -> rec (IntSet.above n)-        TALit (LitNat _ n) _             -> rec (IntSet.singleton n)+        TAGuard (Below y n) _ | x == y -> rec (IntSet.below n)+        TAGuard (Above y n) _ | x == y -> rec (IntSet.above n)+        TALit (LitNat n) _             -> rec (IntSet.singleton n)         _                                -> second (b :) $ go bs cover       where         rec this = second addAlt $ go bs cover'@@ -203,7 +213,7 @@             cover' = this' <> cover             addAlt = case IntSet.toFiniteList this' of                        Just []  -> id                                     -- unreachable case-                       Just [n] -> (TALit (LitNat noRange n) (aBody b) :) -- possibly refined case+                       Just [n] -> (TALit (LitNat n) (aBody b) :) -- possibly refined case                        _        -> (b :)                                  -- unchanged case  data TypeInfo = Empty | Erasable | NotErasable@@ -233,7 +243,7 @@       (rs, t) <- do         (tel, t) <- lift $ typeWithoutParams q         is     <- mapM (getTypeInfo . snd . dget) tel-        used   <- lift $ (++ repeat True) <$> getCompiledArgUse q+        used   <- lift $ (++ repeat ArgUsed) . fromMaybe [] <$> getCompiledArgUse q         forced <- lift $ (++ repeat NotForced) <$> getForcedArgs q         return (zipWith3 (uncurry . mkR . getModality) tel (zip forced used) is, t)       h <- if isAbsurdLambdaName q then pure Erasable else getTypeInfo t@@ -242,10 +252,10 @@       return (rs, h)      -- Treat empty, erasable, or unused arguments as Erasable-    mkR :: Modality -> IsForced -> Bool -> TypeInfo -> TypeInfo-    mkR m f b i+    mkR :: Modality -> IsForced -> ArgUsage -> TypeInfo -> TypeInfo+    mkR m f u i       | not (usableModality m) = Erasable-      | not b                  = Erasable+      | ArgUnused <- u         = Erasable       | Forced <- f            = Erasable       | otherwise              = i @@ -260,7 +270,7 @@  telListView :: Type -> TCM (ListTel, Type) telListView t = do-  TelV tel t <- telView t+  TelV tel t <- telViewPath t   return (telToList tel, t)  typeWithoutParams :: QName -> TCM (ListTel, Type)@@ -286,10 +296,10 @@     Sort{}    -> return Erasable     _         -> return NotErasable   is <- mapM (getTypeInfo . snd . dget) tel-  let e | any (== Empty) is = Erasable-        | null is           = et        -- TODO: guard should really be "all inhabited is"-        | et == Empty       = Erasable-        | otherwise         = et+  let e | Empty `elem` is = Erasable+        | null is         = et        -- TODO: guard should really be "all inhabited is"+        | et == Empty     = Erasable+        | otherwise       = et   lift $ reportSDoc "treeless.opt.erase.type" 50 $ prettyTCM t0 <+> text ("is " ++ show e)   return e   where@@ -299,10 +309,10 @@       msizes <- lift $ mapM getBuiltinName                          [builtinSize, builtinSizeLt]       def    <- lift $ getConstInfo q-      mcs    <- return $ case I.theDef def of-        I.Datatype{ dataCons = cs } -> Just cs-        I.Record{ recConHead = c }  -> Just [conName c]-        _                           -> Nothing+      let mcs = case I.theDef def of+                  I.Datatype{ dataCons = cs } -> Just cs+                  I.Record{ recConHead = c }  -> Just [conName c]+                  _                           -> Nothing       case mcs of         _ | Just q `elem` msizes -> return Erasable         Just [c] -> do@@ -318,6 +328,6 @@             I.Function{ funClauses = cs } ->               sumTypeInfo <$> mapM (maybe (return Empty) (getTypeInfo . El __DUMMY_SORT__) . clauseBody) cs             _ -> return NotErasable-  -- | The backend also has a say whether a type is eraseable or not.+  -- The backend also has a say whether a type is eraseable or not.   erasureForbidden :: QName -> E Bool   erasureForbidden q = lift $ not <$> activeBackendMayEraseType q

src/full/Agda/Compiler/Treeless/GuardsToPrims.hs view

@@ -13,7 +13,7 @@ convertGuards :: TTerm -> TTerm convertGuards = tr   where-    tr t = case t of+    tr = \case       TCase sc t def alts ->         if null otherAlts           then@@ -32,15 +32,15 @@           trAlt (TAGuard{}) = __IMPOSSIBLE__           trAlt a = a { aBody = tr (aBody a) } -      TVar{}    -> t-      TDef{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TLit{}    -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+      t@TVar{}    -> t+      t@TDef{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TLit{}    -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t        TCoerce a               -> TCoerce (tr a)       TLam b                  -> TLam (tr b)

src/full/Agda/Compiler/Treeless/NormalizeNames.hs view

@@ -19,28 +19,23 @@ normalizeNames :: TTerm -> TCM TTerm normalizeNames = tr   where-    tr t = case t of-      TDef q -> do-        q' <- defName <$> getConstInfo q-        return $ TDef q'-      TVar{}    -> done-      TCon{}    -> done-      TPrim{}   -> done-      TLit{}    -> done-      TUnit{}   -> done-      TSort{}   -> done-      TErased{} -> done-      TError{}  -> done-      TLam b                  -> TLam <$> tr b-      TApp a bs               -> TApp <$> tr a <*> mapM tr bs-      TLet e b                -> TLet <$> tr e <*> tr b-      TCase sc t def alts     -> TCase sc t <$> tr def <*> mapM trAlt alts-      TCoerce a               -> TCoerce <$> tr a-      where-        done :: TCM TTerm-        done = return t+    tr = \case+      TDef q              -> TDef . defName <$> getConstInfo q+      t@TVar{}            -> return t+      t@TCon{}            -> return t+      t@TPrim{}           -> return t+      t@TLit{}            -> return t+      t@TUnit{}           -> return t+      t@TSort{}           -> return t+      t@TErased{}         -> return t+      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+      TCase sc t def alts -> TCase sc t <$> tr def <*> mapM trAlt alts+      TCoerce a           -> TCoerce <$> tr a -    trAlt a = case a of+    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

src/full/Agda/Compiler/Treeless/Pretty.hs view

@@ -114,14 +114,14 @@     _    -> Nothing   where     l n   = Just (n, n, n + 1)-    r n   = Just (n, n + 1, n)+    r n   = Just (n, n + 1, n) -- NB:: Defined but not used     non n = Just (n, n + 1, n + 1)  pTerm' :: Int -> TTerm -> P Doc pTerm' p = prec p . pTerm  pTerm :: TTerm -> P Doc-pTerm t = case t of+pTerm = \case   TVar x -> text <$> name x   TApp (TPrim op) [a, b] | Just (c, l, r) <- isInfix op ->     paren c $ sep <$> sequence [ pTerm' l a@@ -143,12 +143,12 @@     paren 9 $ (\a bs -> sep [a, nest 2 $ fsep bs])               <$> pTerm' 9 f               <*> mapM (pTerm' 10) es-  TLam _ -> paren 0 $ withNames' n b $ \ xs -> bindNames xs $+  t@TLam{} -> paren 0 $ withNames' n b $ \ xs -> bindNames xs $     (\b -> sep [ text ("λ " ++ unwords xs ++ " →")                , nest 2 b ]) <$> pTerm' 0 b     where       (n, b) = tLamView t-  TLet{} -> paren 0 $ withNames (length es) $ \ xs ->+  t@TLet{} -> paren 0 $ withNames (length es) $ \ xs ->     (\ (binds, b) -> sep [ "let" <+> vcat [ sep [ text x <+> "="                                                 , nest 2 e ] | (x, e) <- binds ]                               <+> "in", b ])

src/full/Agda/Compiler/Treeless/Simplify.hs view

@@ -2,15 +2,12 @@  import Control.Arrow (second, (***)) import Control.Monad.Reader-import Data.Traversable (traverse) import qualified Data.List as List  import Agda.Syntax.Treeless-import Agda.Syntax.Internal (Substitution'(..)) import Agda.Syntax.Literal  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Primitive import Agda.TypeChecking.Substitute @@ -82,7 +79,7 @@       t@TPrim{} -> pure t       t@TVar{}  -> pure t -      TApp (TDef f) [TLit (LitNat _ 0), m, n, m']+      TApp (TDef f) [TLit (LitNat 0), m, n, m']         -- div/mod are equivalent to quot/rem on natural numbers.         | m == m', Just f == divAux -> simpl $ tOp PQuot n (tPlusK 1 m)         | m == m', Just f == modAux -> simpl $ tOp PRem n (tPlusK 1 m)@@ -121,6 +118,7 @@       TCase x t d bs -> do         v <- lookupVar x         let (lets, u) = tLetView v+        (d, bs) <- pruneBoolGuards d <$> traverse (simplAlt x) bs         case u of                          -- TODO: also for literals           _ | Just (c, as)     <- conView u   -> simpl $ matchCon lets c as d bs             | Just (k, TVar y) <- plusKView u -> simpl . mkLets lets . TCase y t d =<< mapM (matchPlusK y x k) bs@@ -142,8 +140,7 @@               distrCase v (TAGuard g b) = TAGuard g $ TLet b v            _ -> do-            d  <- simpl d-            bs <- traverse (simplAlt x) bs+            d <- simpl d             tCase x t d bs        t@TUnit    -> pure t@@ -183,7 +180,7 @@     -- Simplify let y = x + k in case y of j     -> u; _ | g[y]     -> v     -- to       let y = x + k in case x of j - k -> u; _ | g[x + k] -> v     matchPlusK :: Int -> Int -> Integer -> TAlt -> S TAlt-    matchPlusK x y k (TALit (LitNat r j) b) = return $ TALit (LitNat r (j - k)) b+    matchPlusK x y k (TALit (LitNat j) b) = return $ TALit (LitNat (j - k)) b     matchPlusK x y k (TAGuard g b) = flip TAGuard b <$> simpl (applySubst (inplaceS y (tPlusK k (TVar x))) g)     matchPlusK x y k TACon{} = __IMPOSSIBLE__     matchPlusK x y k TALit{} = __IMPOSSIBLE__@@ -213,6 +210,9 @@       | Just (PAdd, k, u) <- constArithView u,         Just (PAdd, j, v) <- constArithView v,         k == j = tOp PLt u v+      | Just (PSub, k, u) <- constArithView u,+        Just (PSub, j, v) <- constArithView v,+        k == j = tOp PLt v u       | Just (PAdd, k, v) <- constArithView v,         TApp (TPrim P64ToI) [u] <- u,         k >= 2^64, Just trueCon <- true = TCon trueCon@@ -220,6 +220,17 @@       , Just j <- intView v       , Just trueCon <- true       , Just falseCon <- false = if k < j then TCon trueCon else TCon falseCon+    simplPrim' (TApp (TPrim PGeq) [u, v])+      | Just (PAdd, k, u) <- constArithView u,+        Just (PAdd, j, v) <- constArithView v,+        k == j = tOp PGeq u v+      | Just (PSub, k, u) <- constArithView u,+        Just (PSub, j, v) <- constArithView v,+        k == j = tOp PGeq v u+      | Just k <- intView u+      , Just j <- intView v+      , Just trueCon <- true+      , Just falseCon <- false = if k >= j then TCon trueCon else TCon falseCon     simplPrim' (TApp (TPrim op) [u, v])       | op `elem` [PGeq, PLt, PEqI]       , Just (PAdd, k, u) <- constArithView u@@ -259,8 +270,8 @@           opTo64 op = lookup op [(PEqI, PEq64), (PLt, PLt64)]        -- toWord/fromWord k == fromIntegral k-    simplPrim' (TPFn PITo64 (TLit (LitNat r n)))    = TLit (LitWord64 r (fromIntegral n))-    simplPrim' (TPFn P64ToI (TLit (LitWord64 r n))) = TLit (LitNat r    (fromIntegral n))+    simplPrim' (TPFn PITo64 (TLit (LitNat n)))    = TLit (LitWord64 (fromIntegral n))+    simplPrim' (TPFn P64ToI (TLit (LitWord64 n))) = TLit (LitNat    (fromIntegral n))        -- toWord (fromWord a) == a     simplPrim' (TPFn PITo64 (TPFn P64ToI a)) = a@@ -294,9 +305,9 @@     rewrite' t = rewrite =<< simplPrim t      constArithView :: TTerm -> Maybe (TPrim, Integer, TTerm)-    constArithView (TApp (TPrim op) [TLit (LitNat _ k), u])+    constArithView (TApp (TPrim op) [TLit (LitNat k), u])       | op `elem` [PAdd, PSub] = Just (op, k, u)-    constArithView (TApp (TPrim op) [u, TLit (LitNat _ k)])+    constArithView (TApp (TPrim op) [u, TLit (LitNat k)])       | op == PAdd = Just (op, k, u)       | op == PSub = Just (PAdd, -k, u)     constArithView _ = Nothing@@ -357,7 +368,7 @@         overlapped (TALit l _)    (TALit l' _)   = l == l'         overlapped _              _              = False -    -- | Drop unreachable cases for Nat and Int cases.+    -- Drop unreachable cases for Nat and Int cases.     pruneLitCases :: Int -> CaseInfo -> TTerm -> [TAlt] -> S TTerm     pruneLitCases x t d bs | CTNat == caseType t =       case complete bs [] Nothing of@@ -366,9 +377,9 @@       where         complete bs small (Just upper)           | null $ [0..upper - 1] List.\\ small = Just []-        complete (b@(TALit (LitNat _ n) _) : bs) small upper =+        complete (b@(TALit (LitNat n) _) : bs) small upper =           (b :) <$> complete bs (n : small) upper-        complete (b@(TAGuard (TApp (TPrim PGeq) [TVar y, TLit (LitNat _ j)]) _) : bs) small upper | x == y =+        complete (b@(TAGuard (TApp (TPrim PGeq) [TVar y, TLit (LitNat j)]) _) : bs) small upper | x == y =           (b :) <$> complete bs small (Just $ maybe j (min j) upper)         complete _ _ _ = Nothing @@ -376,6 +387,15 @@       | CTInt == caseType t = return $ TCase x t d bs -- TODO       | otherwise           = return $ TCase x t d bs +    -- Drop 'false' branches and drop everything after 'true' branches (including the default+    -- branch)+    pruneBoolGuards d [] = (d, [])+    pruneBoolGuards d (b@(TAGuard (TCon c) _) : bs)+      | Just c == true  = (tUnreachable, [b])+      | Just c == false = pruneBoolGuards d bs+    pruneBoolGuards d (b : bs) =+      second (b :) $ pruneBoolGuards d bs+     tCase' x t d [] = return d     tCase' x t d bs = pruneLitCases x t d bs @@ -400,7 +420,7 @@     tAppAlt (TALit l b) es   = TALit l   <$> tApp b es     tAppAlt (TAGuard g b) es = TAGuard g <$> tApp b es -    isAtomic v = case v of+    isAtomic = \case       TVar{}    -> True       TCon{}    -> True       TPrim{}   -> True

src/full/Agda/Compiler/Treeless/Subst.hs view

@@ -1,16 +1,13 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}  module Agda.Compiler.Treeless.Subst where  import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe-import Data.Monoid ( Monoid, mempty, mappend ) import Data.Semigroup ( Semigroup, (<>), All(..), Any(..) )  import Agda.Syntax.Treeless-import Agda.Syntax.Internal (Substitution'(..)) import Agda.TypeChecking.Substitute  import Agda.Utils.Impossible@@ -20,17 +17,19 @@   deBruijnView (TVar i) = Just i   deBruijnView _ = Nothing -instance Subst TTerm TTerm where-  applySubst IdS t = t-  applySubst rho t = case t of-      TDef{}    -> t-      TLit{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+instance Subst TTerm where+  type SubstArg TTerm = TTerm++  applySubst IdS = id+  applySubst rho = \case+      t@TDef{}    -> t+      t@TLit{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t       TVar i         -> lookupS rho i       TApp f ts      -> tApp (applySubst rho f) (applySubst rho ts)       TLam b         -> TLam (applySubst (liftS 1 rho) b)@@ -45,7 +44,8 @@       tApp (TPrim PSeq) [TErased, b] = b       tApp f ts = TApp f ts -instance Subst TTerm TAlt where+instance Subst TAlt where+  type SubstArg TAlt = TTerm   applySubst rho (TACon c i b) = TACon c i (applySubst (liftS i rho) b)   applySubst rho (TALit l b)   = TALit l (applySubst rho b)   applySubst rho (TAGuard g b) = TAGuard (applySubst rho g) (applySubst rho b)@@ -110,7 +110,7 @@   freeVars (InSeq x) = inSeq <$> freeVars x  instance HasFree TTerm where-  freeVars t = case t of+  freeVars = \case     TDef{}    -> Map.empty     TLit{}    -> Map.empty     TCon{}    -> Map.empty@@ -128,14 +128,14 @@     TCoerce t      -> freeVars t  instance HasFree TAlt where-  freeVars a = case a of+  freeVars = \case     TACon _ i b -> freeVars (Binder i b)     TALit _ b   -> freeVars b     TAGuard g b -> freeVars (g, b)  -- | Strenghtening.-tryStrengthen :: (HasFree a, Subst t a) => Int -> a -> Maybe a+tryStrengthen :: (HasFree a, Subst a) => Int -> a -> Maybe a tryStrengthen n t =   case Map.minViewWithKey (freeVars t) of     Just ((i, _), _) | i < n -> Nothing-    _ -> Just $ applySubst (strengthenS __IMPOSSIBLE__ n) t+    _ -> Just $ applySubst (strengthenS impossible n) t

src/full/Agda/Compiler/Treeless/Uncase.hs view

@@ -5,6 +5,8 @@ import Agda.Compiler.Treeless.Subst import Agda.Compiler.Treeless.Compare +import Agda.Utils.List+ import Agda.Utils.Impossible  caseToSeq :: Monad m => TTerm -> m TTerm@@ -41,7 +43,7 @@         fallback = TCase x t d bs         (fv, mu)           | isUnreachable d =-            case last bs of+            case lastWithDefault __IMPOSSIBLE__ bs of               TACon _ a b -> (a, tryStrengthen a b)               TALit l b   -> (0, Just b)               TAGuard _ b -> (0, Just b)@@ -57,7 +59,7 @@      tLet e b =       case occursIn 0 b of-        Occurs 0 _ _ -> strengthen __IMPOSSIBLE__ b+        Occurs 0 _ _ -> strengthen impossible b         _            -> TLet e b      -- Primitive operations are already strict

src/full/Agda/Compiler/Treeless/Unused.hs view

@@ -4,31 +4,52 @@   , stripUnusedArguments   ) where +import Data.Maybe+ import qualified Data.Set as Set+  -- Andreas, 2021-02-10+  -- TODO: Replace Set by IntSet.+  -- However, this has to wait until we can comfortably bump to+  -- containers-0.6.3.1, which is the first to contain IntSet.mapMonotonic.+  -- Currently, such a constraints gets us into cabal hell.+  -- GHC 8.10 is still shipped with 0.6.2.1, so we either have to wait+  -- until we drop GHC 8 or until we adopt v2-cabal.  import Agda.Syntax.Treeless import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute -import Agda.Compiler.Treeless.Pretty () --instance only+import Agda.Compiler.Treeless.Pretty () -- instance only -import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Function ( iterateUntilM )+import Agda.Utils.List     ( downFrom )+import Agda.Utils.Pretty   ( prettyShow ) -usedArguments :: QName -> TTerm -> TCM [Bool]-usedArguments q t = computeUnused q b (replicate n False)+usedArguments :: QName -> TTerm -> TCM [ArgUsage]+usedArguments q t = computeUnused q b (replicate n ArgUnused)   where (n, b) = tLamView t -computeUnused :: QName -> TTerm -> [Bool] -> TCM [Bool]-computeUnused q t used = do-  reportSLn "treeless.opt.unused" 50 $ "Unused approximation for " ++ prettyShow q ++ ": " ++-                                       unwords [ if u then [x] else "_" | (x, u) <- zip ['a'..] used ]+-- | Saturation algorithm, starting with all unused arguments+--   and adding usages until fixed-point has been reached.++computeUnused :: QName -> TTerm -> [ArgUsage] -> TCM [ArgUsage]+computeUnused q t = iterateUntilM (==) $ \ used -> do++  reportSLn "treeless.opt.unused" 50 $ concat+    [ "Unused approximation for ", prettyShow q, ": "+    , unwords [ if u == ArgUsed then [x] else "_" | (x, u) <- zip ['a'..] used ]+    ]+  -- Update usage information q to so far "best" value.   setCompiledArgUse q used++  -- The new usage information is the free variables of @t@,+  -- computed under the current usage assumptions of the functions it calls.   fv <- go t-  let used' = [ Set.member i fv | (i, _) <- reverse $ zip [0..] used ]-  if used == used' then return used'-                   else computeUnused q t used'+  return $ [ if Set.member i fv then ArgUsed else ArgUnused+           | i <- downFrom (length used)+           ]   where-    go t = case t of+    go = \case       TVar x    -> pure $ Set.singleton x       TPrim{}   -> pure Set.empty       TDef{}    -> pure Set.empty@@ -36,8 +57,8 @@       TCon{}    -> pure Set.empty        TApp (TDef f) ts -> do-        used <- getCompiledArgUse f-        Set.unions <$> sequence [ go t | (t, True) <- zip ts $ used ++ repeat True ]+        used <- fromMaybe [] <$> getCompiledArgUse f+        Set.unions <$> sequence [ go t | (t, ArgUsed) <- zip ts $ used ++ repeat ArgUsed ]        TApp f ts -> Set.unions <$> mapM go (f : ts)       TLam b    -> underBinder <$> go b@@ -60,13 +81,13 @@     underBinders 0 = id     underBinders n = Set.filter (>= 0) . Set.mapMonotonic (subtract n) -stripUnusedArguments :: [Bool] -> TTerm -> TTerm+stripUnusedArguments :: [ArgUsage] -> TTerm -> TTerm stripUnusedArguments used t = mkTLam m $ applySubst rho b   where     (n, b) = tLamView t-    m      = length $ filter id used'-    used'  = reverse $ take n $ used ++ repeat True+    m      = length $ filter (== ArgUsed) used'+    used'  = reverse $ take n $ used ++ repeat ArgUsed     rho = computeSubst used'-    computeSubst (False : bs) = TErased :# computeSubst bs-    computeSubst (True  : bs) = liftS 1 $ computeSubst bs-    computeSubst []           = idS+    computeSubst (ArgUnused : bs) = TErased :# computeSubst bs+    computeSubst (ArgUsed   : bs) = liftS 1 $ computeSubst bs+    computeSubst []               = idS

src/full/Agda/ImpossibleTest.hs view

@@ -1,7 +1,22 @@+-- | Facility to test throwing internal errors.  module Agda.ImpossibleTest where -import Agda.Utils.Impossible+import Agda.TypeChecking.Monad.Base   ( TCM, ReduceM, runReduceM )+import Agda.TypeChecking.Monad.Debug  ( MonadDebug, __IMPOSSIBLE_VERBOSE__ )+import Agda.TypeChecking.Reduce.Monad () -impossibleTest :: a-impossibleTest = __IMPOSSIBLE__+import Agda.Utils.CallStack           ( HasCallStack )+import Agda.Utils.Impossible          ( __IMPOSSIBLE__ )++-- | If the given list of words is non-empty, print them as debug message+--   (using '__IMPOSSIBLE_VERBOSE__') before raising the internal error.+impossibleTest :: (MonadDebug m, HasCallStack) => [String] -> m a+impossibleTest = \case+  []   -> __IMPOSSIBLE__+  strs -> __IMPOSSIBLE_VERBOSE__ $ unwords strs++impossibleTestReduceM :: (HasCallStack) => [String] -> TCM a+impossibleTestReduceM = runReduceM . \case+  []   -> __IMPOSSIBLE__+  strs -> __IMPOSSIBLE_VERBOSE__ $ unwords strs

src/full/Agda/Interaction/Base.hs view

@@ -5,6 +5,7 @@  import           Control.Concurrent.STM.TChan import           Control.Concurrent.STM.TVar+import           Control.Monad.Except import           Control.Monad.Identity import           Control.Monad.State @@ -14,18 +15,17 @@ import           Data.Maybe                   (listToMaybe)  import {-# SOURCE #-} Agda.TypeChecking.Monad.Base-  (HighlightingLevel, HighlightingMethod, TCM, ProblemId, Comparison, Polarity)+  (HighlightingLevel, HighlightingMethod, TCM, Comparison, Polarity, TCErr)  import           Agda.Syntax.Abstract         (QName)-import           Agda.Syntax.Common           (InteractionId (..))+import           Agda.Syntax.Common           (InteractionId (..), Modality)+import           Agda.Syntax.Internal         (ProblemId, Blocker) import           Agda.Syntax.Position import           Agda.Syntax.Scope.Base       (ScopeInfo)  import           Agda.Interaction.Options     (CommandLineOptions,                                                defaultOptions) -import           Agda.Utils.Except            (ExceptT, MonadError (throwError),-                                               runExceptT) import           Agda.Utils.FileName          (AbsolutePath, mkAbsolute) import           Agda.Utils.Time              (ClockTime) @@ -41,11 +41,10 @@     --   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.-  , theCurrentFile       :: Maybe (AbsolutePath, ClockTime)+  , theCurrentFile       :: Maybe CurrentFile     -- ^ The file which the state applies to. Only stored if the     -- module was successfully type checked (potentially with-    -- warnings). The 'ClockTime' is the modification time stamp of-    -- the file when it was last loaded.+    -- warnings).   , optionsOnReload      :: CommandLineOptions     -- ^ Reset the options on each reload to these.   , oldInteractionScopes :: !OldInteractionScopes@@ -79,6 +78,15 @@  type CommandM = StateT CommandState TCM +-- | Information about the current main module.+data CurrentFile = CurrentFile+  { currentFilePath  :: AbsolutePath+      -- ^ The file currently loaded into interaction.+  , currentFileArgs  :: [String]+      -- ^ The arguments to Agda used for loading the file.+  , currentFileStamp :: ClockTime+      -- ^ The modification time stamp of the file when it was loaded.+  } deriving (Show)  ------------------------------------------------------------------------ -- Command queues@@ -130,7 +138,7 @@      -- | Show unsolved metas. If there are no unsolved metas but unsolved constraints     -- show those instead.-  | Cmd_metas+  | Cmd_metas Rewrite      -- | Shows all the top-level names in the given module, along with     -- their types. Uses the top-level scope.@@ -211,6 +219,16 @@   | ToggleImplicitArgs      ------------------------------------------------------------------------+    -- Irrelevant arguments++    -- | Tells Agda whether or not to show irrelevant arguments.+  | ShowIrrelevantArgs    Bool -- Show them?+++    -- | Toggle display of irrelevant arguments.+  | ToggleIrrelevantArgs++    ------------------------------------------------------------------------     -- | Goal commands     --     -- If the range is 'noRange', then the string comes from the@@ -325,7 +343,7 @@ -- | Demand an exact string.  exact :: String -> Parse ()-exact s = readsToParse (show s) $ fmap (\x -> ((),x)) . List.stripPrefix s . dropWhile (==' ')+exact s = readsToParse (show s) $ fmap ((),) . List.stripPrefix s . dropWhile (==' ')  readParse :: Read a => Parse a readParse = readsToParse "read failed" $ listToMaybe . reads@@ -388,10 +406,11 @@               _            -> OtherBackend t     return (b, s) +-- | Ordered ascendingly by degree of normalization. data Rewrite =  AsIs | Instantiated | HeadNormal | Simplified | Normalised-    deriving (Show, Read)+    deriving (Show, Read, Eq, Ord) -data ComputeMode = DefaultCompute | IgnoreAbstract | UseShowInstance+data ComputeMode = DefaultCompute | HeadCompute | IgnoreAbstract | UseShowInstance   deriving (Show, Read, Eq)  data UseForce@@ -399,7 +418,7 @@   | WithoutForce  -- ^ Don't ignore any checks.   deriving (Eq, Read, Show) -data OutputForm a b = OutputForm Range [ProblemId] (OutputConstraint a b)+data OutputForm a b = OutputForm Range [ProblemId] Blocker (OutputConstraint a b)   deriving (Functor)  data OutputConstraint a b@@ -409,13 +428,14 @@                    | CmpLevels Comparison b b                    | CmpTeles Comparison b b       | JustSort b | CmpSorts Comparison b b-      | Guard (OutputConstraint a b) ProblemId       | Assign b a | TypedAssign b a a | PostponedCheckArgs b [a] a a       | IsEmptyType a       | SizeLtSat a-      | FindInstanceOF b a [(a,a)]+      | FindInstanceOF b a [(a,a,a)]       | PTSInstance b b-      | PostponedCheckFunDef QName a+      | PostponedCheckFunDef QName a TCErr+      | CheckLock b b+      | UsableAtMod Modality b   deriving (Functor)  -- | A subset of 'OutputConstraint'.

src/full/Agda/Interaction/BasicOps.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE NondecreasingIndentation #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -9,6 +7,7 @@ import Prelude hiding (null)  import Control.Arrow (first)+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Identity@@ -20,10 +19,11 @@ import Data.Maybe import Data.Monoid import Data.Function (on)+import Data.Text (Text)+import qualified Data.Text as T  import Agda.Interaction.Base import Agda.Interaction.Options-import {-# SOURCE #-} Agda.Interaction.Imports (MaybeWarnings'(..), getMaybeWarnings) import Agda.Interaction.Response (Goals, ResponseContextEntry(..))  import qualified Agda.Syntax.Concrete as C -- ToDo: Remove with instance of ToConcrete@@ -47,7 +47,7 @@ import Agda.TheTypeChecker import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Errors ( stringTCErr )+import Agda.TypeChecking.Errors ( getAllWarnings, stringTCErr ) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.MetaVars.Mention@@ -73,16 +73,18 @@  import Agda.Termination.TermCheck (termMutual) -import Agda.Utils.Except ( MonadError(catchError, throwError) ) 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.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Pretty as P import Agda.Utils.Permutation import Agda.Utils.Size+import Agda.Utils.String  import Agda.Utils.Impossible @@ -134,27 +136,22 @@             [ TP.text ("give(" ++ show a ++ "): instantiated meta type =")             , prettyTCM t'             ]-        v <- checkExpr e t'+        -- Andreas, 2020-05-27 AIM XXXII, issue #4679+        -- Clear envMutualBlock since cubical only executes+        -- certain checks (checkIApplyConfluence) for an extended lambda+        -- when not in a mutual block.+        v <- locallyTC eMutualBlock (const Nothing) $+          checkExpr e t'         case mvInstantiation mv of -          InstV xs v' -> unlessM ((Irrelevant ==) <$> asksTC getRelevance) $ do+          InstV{} -> unlessM ((Irrelevant ==) <$> asksTC getRelevance) $ do+            v' <- instantiate $ MetaV mi $ map Apply ctx             reportSDoc "interaction.give" 20 $ TP.sep               [ "meta was already set to value v' = " TP.<+> prettyTCM v'-                TP.<+> " with free variables " TP.<+> return (fsep $ map pretty xs)               , "now comparing it to given value v = " TP.<+> prettyTCM v               , "in context " TP.<+> inTopContext (prettyTCM ctx)               ]-            -- The number of free variables should be at least the size of the context-            -- (Ideally, if we implemented contextual type theory, it should be the same.)-            when (length xs < size ctx) __IMPOSSIBLE__-            -- if there are more free variables than the context has-            -- we need to abstract over the additional ones (xs2)-            let (_xs1, xs2) = splitAt (size ctx) xs-            v' <- return $ foldr mkLam v' xs2-            reportSDoc "interaction.give" 20 $ TP.sep-              [ "in meta context, v' = " TP.<+> prettyTCM v'-              ]-            equalTerm t' v v'  -- Note: v' now lives in context of meta+            equalTerm t' v v'            _ -> do -- updateMeta mi v             reportSLn "interaction.give" 20 "give: meta unassigned, assigning..."@@ -209,7 +206,7 @@      giveExpr force (Just ii) mi e     `catchError` \ case       -- Turn PatternErr into proper error:-      PatternErr -> typeError . GenericDocError =<< do+      PatternErr{} -> typeError . GenericDocError =<< do         withInteractionId ii $ "Failed to give" TP.<+> prettyTCM e       err -> throwError err   removeInteractionPoint ii@@ -239,11 +236,15 @@   tryRefine 10 range scope e   where     tryRefine :: Int -> Range -> ScopeInfo -> Expr -> TCM Expr-    tryRefine nrOfMetas r scope e = try nrOfMetas e+    tryRefine nrOfMetas r scope = try nrOfMetas Nothing       where-        try :: Int -> Expr -> TCM Expr-        try 0 e = throwError $ stringTCErr "Cannot refine"-        try n e = give force ii (Just r) e `catchError` (\_ -> try (n - 1) =<< appMeta e)+        try :: Int -> Maybe TCErr -> Expr -> TCM Expr+        try 0 err e = throwError . stringTCErr $ case err of+           Just (TypeError _ _ cl) | UnequalTerms _ I.Pi{} _ _ <- clValue cl ->+             "Cannot refine functions with 10 or more arguments"+           _ ->+             "Cannot refine"+        try n _ e = give force ii (Just r) e `catchError` \err -> try (n - 1) (Just err) =<< appMeta e          -- Apply A.Expr to a new meta         appMeta :: Expr -> TCM Expr@@ -267,9 +268,9 @@                       isX _                  = mempty                lamView (A.Lam _ (DomainFree _ x) e) = Just (namedArg x, e)-              lamView (A.Lam i (DomainFull (TBind r t (x : xs) a)) e)-                | null xs   = Just (namedArg x, e)-                | otherwise = Just (namedArg x, A.Lam i (DomainFull $ TBind r t xs a) e)+              lamView (A.Lam i (DomainFull (TBind r t (x :| xs) a)) e) =+                List1.ifNull xs {-then-} (Just (namedArg x, e)) {-else-} $ \ xs ->+                  Just (namedArg x, A.Lam i (DomainFull $ TBind r t xs a) e)               lamView _ = Nothing                -- reduce beta-redexes where the argument is used at most once@@ -296,35 +297,38 @@ -- rescopeExpr scope = withScope_ scope . (concreteToAbstract_ <=< runAbsToCon . preserveInteractionIds . toConcrete)  {-| Evaluate the given expression in the current environment -}-evalInCurrent :: Expr -> TCM Expr-evalInCurrent e =-    do  (v, t) <- inferExpr e-        v' <- {- etaContract =<< -} normalise v-        reify v'+evalInCurrent :: ComputeMode -> Expr -> TCM Expr+evalInCurrent cmode e = do+  (v, _t) <- inferExpr e+  reify =<< compute v+  where compute | cmode == HeadCompute = reduce+                | otherwise            = normalise  -evalInMeta :: InteractionId -> Expr -> TCM Expr-evalInMeta ii e =+evalInMeta :: InteractionId -> ComputeMode -> Expr -> TCM Expr+evalInMeta ii cmode e =    do   m <- lookupInteractionId ii         mi <- getMetaInfo <$> lookupMeta m         withMetaInfo mi $-            evalInCurrent e+            evalInCurrent cmode e  -- | Modifier for interactive commands, --   specifying the amount of normalization in the output. ---normalForm :: (Reduce t, Simplify t, Normalise t) => Rewrite -> t -> TCM t-normalForm AsIs         t = return t-normalForm Instantiated t = return t   -- reify does instantiation-normalForm HeadNormal   t = {- etaContract =<< -} reduce t-normalForm Simplified   t = {- etaContract =<< -} simplify t-normalForm Normalised   t = {- etaContract =<< -} normalise t+normalForm :: (Reduce t, Simplify t, Instantiate t, Normalise t) => Rewrite -> t -> TCM t+normalForm = \case+  AsIs         -> instantiate   -- #4975: reify will also instantiate by for goal-type-and-context-and-check+  Instantiated -> instantiate   --        we get a top-level fresh meta which has disappeared from state by the+  HeadNormal   -> reduce        --        time we get to reification. Hence instantiate here.+  Simplified   -> simplify+  Normalised   -> normalise  -- | Modifier for the interactive computation command, --   specifying the mode of computation and result display. -- computeIgnoreAbstract :: ComputeMode -> Bool computeIgnoreAbstract DefaultCompute  = False+computeIgnoreAbstract HeadCompute     = False computeIgnoreAbstract IgnoreAbstract  = True computeIgnoreAbstract UseShowInstance = True   -- UseShowInstance requires the result to be a string literal so respecting@@ -337,16 +341,16 @@ showComputed :: ComputeMode -> Expr -> TCM Doc showComputed UseShowInstance e =   case e of-    A.Lit (LitString _ s) -> pure (text s)+    A.Lit _ (LitString s) -> pure (text $ T.unpack s)     _                     -> ("Not a string:" $$) <$> prettyATop e showComputed _ e = prettyATop e  -- | Modifier for interactive commands, --   specifying whether safety checks should be ignored. outputFormId :: OutputForm a b -> b-outputFormId (OutputForm _ _ o) = out o+outputFormId (OutputForm _ _ _ o) = out o   where-    out o = case o of+    out = \case       OfType i _                 -> i       CmpInType _ _ i _          -> i       CmpElim _ _ (i:_) _        -> i@@ -357,7 +361,6 @@       CmpTeles _ i _             -> i       JustSort i                 -> i       CmpSorts _ i _             -> i-      Guard o _                  -> out o       Assign i _                 -> i       TypedAssign i _ _          -> i       PostponedCheckArgs i _ _ _ -> i@@ -366,21 +369,26 @@       FindInstanceOF _ _ _        -> __IMPOSSIBLE__       PTSInstance i _            -> i       PostponedCheckFunDef{}     -> __IMPOSSIBLE__+      CheckLock i _              -> i+      UsableAtMod _ i            -> i -instance Reify ProblemConstraint (Closure (OutputForm Expr Expr)) where-  reify (PConstr pids cl) = withClosure cl $ \ c ->-    OutputForm (getRange c) (Set.toList pids) <$> reify c+instance Reify ProblemConstraint where+  type ReifiesTo ProblemConstraint = Closure (OutputForm Expr Expr)+  reify (PConstr pids unblock cl) = withClosure cl $ \ c ->+    OutputForm (getRange c) (Set.toList pids) unblock <$> reify c  reifyElimToExpr :: MonadReify m => I.Elim -> m Expr-reifyElimToExpr e = case e of+reifyElimToExpr = \case     I.IApply _ _ v -> appl "iapply" <$> reify (defaultArg $ v) -- TODO Andrea: endpoints?     I.Apply v -> appl "apply" <$> reify v     I.Proj _o f -> appl "proj" <$> reify ((defaultArg $ I.Def f []) :: Arg Term)   where-    appl :: String -> Arg Expr -> Expr-    appl s v = A.App defaultAppInfo_ (A.Lit (LitString noRange s)) $ fmap unnamed v+    appl :: Text -> Arg Expr -> Expr+    appl s v = A.App defaultAppInfo_ (A.Lit empty (LitString s)) $ fmap unnamed v -instance Reify Constraint (OutputConstraint Expr Expr) where+instance Reify Constraint where+    type ReifiesTo Constraint = OutputConstraint Expr Expr+     reify (ValueCmp cmp (AsTermsOf t) u v) = CmpInType cmp <$> reify t <*> reify u <*> reify v     reify (ValueCmp cmp AsSizes u v) = CmpInType cmp <$> (reify =<< sizeType) <*> reify u <*> reify v     reify (ValueCmp cmp AsTypes u v) = CmpTypes cmp <$> reify u <*> reify v@@ -395,12 +403,8 @@       CmpElim cmp <$> reify t <*> mapM reifyElimToExpr es1                               <*> mapM reifyElimToExpr es2     reify (LevelCmp cmp t t')    = CmpLevels cmp <$> reify t <*> reify t'-    reify (TelCmp a b cmp t t')  = CmpTeles cmp <$> (ETel <$> reify t) <*> (ETel <$> reify t')     reify (SortCmp cmp s s')     = CmpSorts cmp <$> reify s <*> reify s'-    reify (Guarded c pid) = do-        o  <- reify c-        return $ Guard o pid-    reify (UnquoteTactic _ tac _ goal) = do+    reify (UnquoteTactic tac _ goal) = do         tac <- A.App defaultAppInfo_ (A.Unquote exprNoRange) . defaultNamedArg <$> reify tac         OfType tac <$> reify goal     reify (UnBlock m) = do@@ -410,7 +414,7 @@           BlockedConst t -> do             e  <- reify t             return $ Assign m' e-          PostponedTypeCheckingProblem cl _ -> enterClosure cl $ \case+          PostponedTypeCheckingProblem cl -> enterClosure cl $ \case             CheckExpr cmp e a -> do                 a  <- reify a                 return $ TypedAssign m' e a@@ -418,45 +422,56 @@               domType <- maybe (return underscore) reify mt               target  <- reify target               let mkN (WithHiding h x) = setHiding h $ defaultNamedArg $ A.mkBinder_ x-                  bs = mkTBind noRange (map mkN xs) domType+                  bs = mkTBind noRange (fmap mkN xs) domType                   e  = A.Lam Info.exprNoRange (DomainFull bs) body               return $ TypedAssign m' e target-            CheckArgs _ _ args t0 t1 _ -> do+            CheckArgs _ _ _ args t0 t1 _ -> do               t0 <- reify t0               t1 <- reify t1               return $ PostponedCheckArgs m' (map (namedThing . unArg) args) t0 t1-            CheckProjAppToKnownPrincipalArg cmp e _ _ _ t _ _ _ -> TypedAssign m' e <$> reify t+            CheckProjAppToKnownPrincipalArg cmp e _ _ _ t _ _ _ _ -> TypedAssign m' e <$> reify t             DoQuoteTerm cmp v t -> do               tm <- A.App defaultAppInfo_ (A.QuoteTerm exprNoRange) . defaultNamedArg <$> reify v               OfType tm <$> reify t           Open{}  -> __IMPOSSIBLE__           OpenInstance{}  -> __IMPOSSIBLE__           InstV{} -> __IMPOSSIBLE__-    reify (FindInstance m _b mcands) = FindInstanceOF-      <$> (reify $ MetaV m [])+    reify (FindInstance m mcands) = FindInstanceOF+      <$> reify (MetaV m [])       <*> (reify =<< getMetaType m)-      <*> (forM (fromMaybe [] mcands) $ \ (Candidate tm ty _) -> do-            (,) <$> reify tm <*> reify ty)+      <*> forM (fromMaybe [] mcands) (\ (Candidate q tm ty _) -> do+            (,,) <$> reify tm <*> reify tm <*> reify ty)     reify (IsEmpty r a) = IsEmptyType <$> reify a     reify (CheckSizeLtSat a) = SizeLtSat  <$> reify a-    reify (CheckFunDef d i q cs) = do+    reify (CheckFunDef d i q cs err) = do       a <- reify =<< defType <$> getConstInfo q-      return $ PostponedCheckFunDef q a+      return $ PostponedCheckFunDef q a err     reify (HasBiggerSort a) = OfType <$> reify a <*> reify (UnivSort a)     reify (HasPTSRule a b) = do       (a,(x,b)) <- reify (unDom a,b)       return $ PTSInstance a b+    reify (CheckLockedVars t _ lk _) = CheckLock <$> reify t <*> reify (unArg lk)     reify (CheckMetaInst m) = do       t <- jMetaType . mvJudgement <$> lookupMeta m       OfType <$> reify (MetaV m []) <*> reify t-+    reify (UsableAtModality mod t) = UsableAtMod mod <$> reify t  instance (Pretty a, Pretty b) => Pretty (OutputForm a b) where-  pretty (OutputForm r pids c) = sep [pretty c, nest 2 $ prange r, nest 2 $ prPids pids]+  pretty (OutputForm r pids unblock c) =+    pretty c <?>+      sep [ prange r, parensNonEmpty (sep [blockedOn unblock, prPids pids]) ]     where       prPids []    = empty-      prPids [pid] = parens $ "problem" <+> pretty pid-      prPids pids  = parens $ "problems" <+> fsep (punctuate "," $ map pretty pids)+      prPids [pid] = "belongs to problem" <+> pretty pid+      prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map pretty pids)++      comma | null pids = empty+            | 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)+       prange r | null s = empty                | otherwise = text $ " [ at " ++ s ++ " ]"         where s = prettyShow r@@ -473,7 +488,6 @@       CmpLevels cmp t t'   -> pcmp cmp t t'       CmpTeles  cmp t t'   -> pcmp cmp t t'       CmpSorts cmp s s'    -> pcmp cmp s s'-      Guard o pid          -> pretty o <?> parens ("blocked by problem" <+> pretty pid)       Assign m e           -> bin (pretty m) ":=" (pretty e)       TypedAssign m e a    -> bin (pretty m) ":=" $ bin (pretty e) ":?" (pretty a)       PostponedCheckArgs m es t0 t1 ->@@ -484,21 +498,26 @@       FindInstanceOF s t cs -> vcat         [ "Resolve instance argument" <?> (pretty s .: t)         , nest 2 $ "Candidate:"-        , nest 4 $ vcat [ pretty v .: t | (v, t) <- cs ] ]+        , nest 4 $ vcat [ bin (pretty q) "=" (pretty v) .: t | (q, v, t) <- cs ] ]       PTSInstance a b      -> "PTS instance for" <+> pretty (a, b)-      PostponedCheckFunDef q a -> "Check definition of" <+> pretty q <+> ":" <+> pretty a+      PostponedCheckFunDef q a _err ->+        vcat [ "Check definition of" <+> pretty q <+> ":" <+> pretty a ]+             -- , nest 2 "stuck because" <?> pretty err ] -- We don't have Pretty for TCErr+      CheckLock t lk       -> "Check lock" <+> pretty lk <+> "allows" <+> pretty t+      UsableAtMod mod t    -> "Is usable at" <+> pretty mod <+> pretty t     where       bin a op b = sep [a, nest 2 $ op <+> b]       pcmp cmp a b = bin (pretty a) (pretty cmp) (pretty b)       val .: ty = bin val ":" (pretty ty)  -instance (ToConcrete a c, ToConcrete b d) =>-         ToConcrete (OutputForm a b) (OutputForm c d) where-    toConcrete (OutputForm r pid c) = OutputForm r pid <$> toConcrete c+instance (ToConcrete a, ToConcrete b) => ToConcrete (OutputForm a b) where+    type ConOfAbs (OutputForm a b) = OutputForm (ConOfAbs a) (ConOfAbs b)+    toConcrete (OutputForm r pid u c) = OutputForm r pid u <$> toConcrete c -instance (ToConcrete a c, ToConcrete b d) =>-         ToConcrete (OutputConstraint a b) (OutputConstraint c d) where+instance (ToConcrete a, ToConcrete b) => ToConcrete (OutputConstraint a b) where+    type ConOfAbs (OutputConstraint a b) = OutputConstraint (ConOfAbs a) (ConOfAbs b)+     toConcrete (OfType e t) = OfType <$> toConcrete e <*> toConcreteCtx TopCtx t     toConcrete (JustType e) = JustType <$> toConcrete e     toConcrete (JustSort e) = JustSort <$> toConcrete e@@ -514,7 +533,6 @@     toConcrete (CmpTeles cmp e e') = CmpTeles cmp <$> toConcrete e <*> toConcrete e'     toConcrete (CmpSorts cmp e e') = CmpSorts cmp <$> toConcreteCtx TopCtx e                                                   <*> toConcreteCtx TopCtx e'-    toConcrete (Guard o pid) = Guard <$> toConcrete o <*> pure pid     toConcrete (Assign m e) = noTakenNames $ Assign <$> toConcrete m <*> toConcreteCtx TopCtx e     toConcrete (TypedAssign m e a) = TypedAssign <$> toConcrete m <*> toConcreteCtx TopCtx e                                                                   <*> toConcreteCtx TopCtx a@@ -524,21 +542,26 @@     toConcrete (SizeLtSat a) = SizeLtSat <$> toConcreteCtx TopCtx a     toConcrete (FindInstanceOF s t cs) =       FindInstanceOF <$> toConcrete s <*> toConcrete t-                     <*> mapM (\(tm,ty) -> (,) <$> toConcrete tm <*> toConcrete ty) cs+                     <*> mapM (\(q,tm,ty) -> (,,) <$> toConcrete q <*> toConcrete tm <*> toConcrete ty) cs     toConcrete (PTSInstance a b) = PTSInstance <$> toConcrete a <*> toConcrete b-    toConcrete (PostponedCheckFunDef q a) = PostponedCheckFunDef q <$> toConcrete a+    toConcrete (CheckLock a b) = CheckLock <$> toConcrete a <*> toConcrete b+    toConcrete (PostponedCheckFunDef q a err) = PostponedCheckFunDef q <$> toConcrete a <*> pure err+    toConcrete (UsableAtMod a b) = UsableAtMod a <$> toConcrete b  instance (Pretty a, Pretty b) => Pretty (OutputConstraint' a b) where   pretty (OfType' e t) = pretty e <+> ":" <+> pretty t -instance (ToConcrete a c, ToConcrete b d) =>-            ToConcrete (OutputConstraint' a b) (OutputConstraint' c d) where+instance (ToConcrete a, ToConcrete b) => ToConcrete (OutputConstraint' a b) where+  type ConOfAbs (OutputConstraint' a b) = OutputConstraint' (ConOfAbs a) (ConOfAbs b)   toConcrete (OfType' e t) = OfType' <$> toConcrete e <*> toConcreteCtx TopCtx t -instance Reify a e => Reify (IPBoundary' a) (IPBoundary' e) where+instance Reify a => Reify (IPBoundary' a) where+  type ReifiesTo (IPBoundary' a) = IPBoundary' (ReifiesTo a)   reify = traverse reify -instance ToConcrete a c => ToConcrete (IPBoundary' a) (IPBoundary' c) where+instance ToConcrete a => ToConcrete (IPBoundary' a) where+  type ConOfAbs (IPBoundary' a) = IPBoundary' (ConOfAbs a)+   toConcrete = traverse (toConcreteCtx TopCtx)  instance Pretty c => Pretty (IPBoundary' c) where@@ -550,11 +573,10 @@               NotOverapplied -> mempty     prettyList_ xs <+> "⊢" <+> pretty val <+> rhs - prettyConstraints :: [Closure Constraint] -> TCM [OutputForm C.Expr C.Expr] prettyConstraints cs = do   forM cs $ \ c -> do-            cl <- reify (PConstr Set.empty c)+            cl <- reify (PConstr Set.empty alwaysUnblock c)             enterClosure cl abstractToConcrete_  getConstraints :: TCM [OutputForm C.Expr C.Expr]@@ -586,9 +608,7 @@         -- TODO: extend to other comparisons?         ElimCmp cmp fs t v as bs   -> Nothing         LevelCmp cmp u v           -> Nothing-        TelCmp a b cmp tela telb   -> Nothing         SortCmp cmp a b            -> Nothing-        Guarded c pid              -> hasHeadMeta c         UnBlock{}                  -> Nothing         FindInstance{}             -> Nothing         IsEmpty r t                -> isMeta (unEl t)@@ -598,6 +618,8 @@         HasPTSRule a b             -> Nothing         UnquoteTactic{}            -> Nothing         CheckMetaInst{}            -> Nothing+        CheckLockedVars t _ _ _    -> isMeta t+        UsableAtModality _ t       -> isMeta t      isMeta (MetaV m' es_m)       | m == m' = Just es_m@@ -606,27 +628,25 @@     getConstrs g f = liftTCM $ do       cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints)       reportSDoc "constr.ment" 20 $ "getConstraintsMentioning"-      forM cs $ \(PConstr s c) -> do+      forM cs $ \(PConstr s ub c) -> do         c <- normalForm norm c         case allApplyElims =<< hasHeadMeta (clValue c) of           Just as_m -> do             -- unifyElimsMeta tries to move the constraint into             -- (an extension of) the context where @m@ comes from.             unifyElimsMeta m as_m c $ \ eqs c -> do-              flip enterClosure abstractToConcrete_ =<< reify . PConstr s =<< buildClosure c+              flip enterClosure abstractToConcrete_ =<< reify . PConstr s ub =<< buildClosure c           _ -> do-            cl <- reify $ PConstr s c+            cl <- reify $ PConstr s ub c             enterClosure cl abstractToConcrete_  -- Copied from Agda.TypeChecking.Pretty.Warning.prettyConstraints stripConstraintPids :: Constraints -> Constraints stripConstraintPids cs = List.sortBy (compare `on` isBlocked) $ map stripPids cs   where-    isBlocked = not . null . blocking . clValue . theConstraint-    interestingPids = Set.fromList $ concatMap (blocking . clValue . theConstraint) cs-    stripPids (PConstr pids c) = PConstr (Set.intersection pids interestingPids) c-    blocking (Guarded c pid) = pid : blocking c-    blocking _               = []+    isBlocked = not . null . allBlockingProblems . constraintUnblocker+    interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs+    stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c  getConstraints' :: (ProblemConstraint -> TCM ProblemConstraint) -> (ProblemConstraint -> Bool) -> TCM [OutputForm C.Expr C.Expr] getConstraints' g f = liftTCM $ do@@ -641,7 +661,7 @@       mv <- getMetaInfo <$> lookupMeta mi       withMetaInfo mv $ do         let m = QuestionMark emptyMetaInfo{ metaNumber = Just $ fromIntegral ii } ii-        abstractToConcrete_ $ OutputForm noRange [] $ Assign m e+        abstractToConcrete_ $ OutputForm noRange [] alwaysUnblock $ Assign m e   getIPBoundary :: Rewrite -> InteractionId -> TCM [IPBoundary' C.Expr]@@ -656,19 +676,24 @@ -- | Goals and Warnings  getGoals :: TCM Goals-getGoals = do+getGoals = getGoals' AsIs Simplified   -- visible metas (as-is)-  visibleMetas <- typesOfVisibleMetas AsIs   -- hidden metas (unsolved implicit arguments simplified)-  unsolvedNotOK <- not . optAllowUnsolved <$> pragmaOptions-  hiddenMetas <- (guard unsolvedNotOK >>) <$> typesOfHiddenMetas Simplified++getGoals'+  :: Rewrite    -- ^ Degree of normalization of goals.+  -> Rewrite    -- ^ Degree of normalization of hidden goals.+  -> TCM Goals+getGoals' normVisible normHidden = do+  visibleMetas <- typesOfVisibleMetas normVisible+  hiddenMetas <- typesOfHiddenMetas normHidden   return (visibleMetas, hiddenMetas)  -- | Print open metas nicely. showGoals :: Goals -> TCM String showGoals (ims, hms) = do   di <- forM ims $ \ i ->-    withInteractionId (outputFormId $ OutputForm noRange [] i) $+    withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock i) $       prettyATop i   dh <- mapM showA' hms   return $ unlines $ map show di ++ dh@@ -678,14 +703,14 @@       let i = nmid $ namedMetaOf m       r <- getMetaRange i       d <- withMetaId i (prettyATop m)-      return $ show d ++ "  [ at " ++ show r ++ " ]"+      return $ show d ++ "  [ at " ++ prettyShow r ++ " ]"  getWarningsAndNonFatalErrors :: TCM WarningsAndNonFatalErrors getWarningsAndNonFatalErrors = do-  mws <- getMaybeWarnings AllWarnings-  let notMetaWarnings = filter (not . isMetaTCWarning) <$> mws+  mws <- getAllWarnings AllWarnings+  let notMetaWarnings = filter (not . isMetaTCWarning) mws   return $ case notMetaWarnings of-    SomeWarnings ws@(_:_) -> classifyWarnings ws+    ws@(_:_) -> classifyWarnings ws     _ -> emptyWarningsAndNonFatalErrors  -- | Collecting the context of the given meta-variable.@@ -814,17 +839,17 @@       -- so we'd better rename any actual 'w's to avoid confusion.       tel  <- runIdentity . onNamesTel unW <$> getContextTelescope       let a = runIdentity . onNames unW $ a0-      vtys <- mapM (\ a -> fmap (WithHiding (getHiding a) . fmap OtherType) $ inferExpr $ namedArg a) args+      vtys <- mapM (\ a -> fmap (Arg (getArgInfo a) . fmap OtherType) $ inferExpr $ namedArg a) args       -- Remember the arity of a       TelV atel _ <- telView a       let arity = size atel           (delta1, delta2, _, a', vtys') = splitTelForWith tel a vtys       a <- localTC (\e -> e { envPrintDomainFreePi = True }) $ do-        reify =<< cleanupType arity args =<< normalForm norm =<< fst <$> withFunctionType delta1 vtys' delta2 a'+        reify =<< cleanupType arity args =<< normalForm norm =<< fst <$> withFunctionType delta1 vtys' delta2 a' []       reportSDoc "interaction.helper" 10 $ TP.vcat $         let extractOtherType = \case { OtherType a -> a; _ -> __IMPOSSIBLE__ } in-        let (vs, as)   = unzipWith (fmap extractOtherType . whThing) vtys in-        let (vs', as') = unzipWith (fmap extractOtherType . whThing) vtys' in+        let (vs, as)   = unzipWith (fmap extractOtherType . unArg) vtys in+        let (vs', as') = unzipWith (fmap extractOtherType . unArg) vtys' in         [ "generating helper function"         , TP.nest 2 $ "tel    = " TP.<+> inTopContext (prettyTCM tel)         , TP.nest 2 $ "a      = " TP.<+> prettyTCM a@@ -844,11 +869,6 @@       flip (caseMaybe $ isName ce) (\ _ -> return ()) $ do          reportSLn "interaction.helper" 10 $ "ce = " ++ show ce          failure-    isName :: C.Expr -> Maybe C.Name-    isName = \case-      C.Ident (C.QName x)              -> Just x-      C.RawApp _ [C.Ident (C.QName x)] -> Just x-      _ -> Nothing     isVar :: A.Expr -> Maybe A.Name     isVar = \case       A.Var x -> Just x@@ -868,14 +888,14 @@      -- Strip the non-dependent abstractions from the first n abstractions.     stripUnused n (El s v) = El s $ strip n v-    strip 0 v = v-    strip n v = case v of+    strip 0 = id+    strip n = \case       I.Pi a b -> case stripUnused (n-1) <$> b of         b | absName b == "w"   -> I.Pi a b         NoAbs _ b              -> unEl b         Abs s b | 0 `freeIn` b -> I.Pi (hide a) (Abs s b)-                | otherwise    -> strengthen __IMPOSSIBLE__ (unEl b)-      _ -> v  -- todo: handle if goal type is a Pi+                | otherwise    -> strengthen impossible (unEl b)+      v -> v  -- todo: handle if goal type is a Pi      -- renameVars = onNames (stringToArgName <.> renameVar . argNameToString)     renameVars = onNames renameVar@@ -889,18 +909,18 @@     onNamesTel f I.EmptyTel = pure I.EmptyTel     onNamesTel f (I.ExtendTel a b) = I.ExtendTel <$> traverse (onNames f) a <*> onNamesAbs f onNamesTel b -    onNamesTm f v = case v of+    onNamesTm f = \case       I.Var x es   -> I.Var x <$> onNamesElims f es       I.Def q es   -> I.Def q <$> onNamesElims f es       I.Con c ci args -> I.Con c ci <$> onNamesArgs f args       I.Lam i b    -> I.Lam i <$> onNamesAbs f onNamesTm b       I.Pi a b     -> I.Pi <$> traverse (onNames f) a <*> onNamesAbs f onNames b       I.DontCare v -> I.DontCare <$> onNamesTm f v-      I.Lit{}      -> pure v-      I.Sort{}     -> pure v-      I.Level{}    -> pure v-      I.MetaV{}    -> pure v-      I.Dummy{}    -> pure v+      v@I.Lit{}    -> pure v+      v@I.Sort{}   -> pure v+      v@I.Level{}  -> pure v+      v@I.MetaV{}  -> pure v+      v@I.Dummy{}  -> pure v     onNamesElims f = traverse $ traverse $ onNamesTm f     onNamesArgs f  = traverse $ traverse $ onNamesTm f     onNamesAbs f   = onNamesAbs' f (stringToArgName <.> f . argNameToString)@@ -934,8 +954,7 @@   withMetaInfo info $ do     -- List of local variables.     cxt <- getContext-    let n         = length cxt-        localVars = zipWith raise [1..] cxt+    let localVars = zipWith raise [1..] cxt     -- List of let-bindings.     letVars <- Map.toAscList <$> asksTC envLetBindings     -- Reify the types and filter out bindings without a name.@@ -1040,6 +1059,9 @@     conName [p] = [ c | I.ConP c _ _ <- [namedArg p] ]     conName _   = __IMPOSSIBLE__ +    showUnambiguousConName v =+       render . pretty <$> runAbsToCon (lookupQName AmbiguousNothing $ I.conName v)+     showTCM :: PrettyTCM a => a -> TCM String     showTCM v = render <$> prettyTCM v @@ -1050,7 +1072,7 @@         let okHiding0 h = imp || h == NotHidden             -- if none of the vars were displayed, we would get a parse error             -- thus, we switch to displaying all-            allHidden   = null (filter okHiding0 hs)+            allHidden   = not (any okHiding0 hs)             okHiding    = if allHidden then const True else okHiding0         vars <- -- setShowImplicitArguments (imp || allHidden) $                 (if allHidden then withShowAllArguments else id) $@@ -1075,7 +1097,8 @@       r <- splitLast CoInductive tel pat       case r of         Left err -> return []-        Right cov -> mapM showTCM $ concatMap (conName . scPats) $ splitClauses cov+        Right cov ->+           mapM showUnambiguousConName $ concatMap (conName . scPats) $ splitClauses cov      introRec :: QName -> TCM [String]     introRec d = do@@ -1147,21 +1170,21 @@ -- | Parse a name. parseName :: Range -> String -> TCM C.QName parseName r s = do-  m <- parseExpr r s-  case m of-    C.Ident m              -> return m-    C.RawApp _ [C.Ident m] -> return m-    _                      -> typeError $-      GenericError $ "Not an identifier: " ++ show m ++ "."+  e <- parseExpr r s+  let failure = typeError $ GenericError $ "Not an identifier: " ++ show e ++ "."+  maybe failure return $ isQName e  -- | Check whether an expression is a (qualified) identifier. isQName :: C.Expr -> Maybe C.QName-isQName m = do-  case m of-    C.Ident m              -> return m-    C.RawApp _ [C.Ident m] -> return m-    _ -> Nothing+isQName = \case+  C.Ident x                    -> return x+  _ -> Nothing +isName :: C.Expr -> Maybe C.Name+isName = isQName >=> \case+  C.QName x -> return x+  _ -> Nothing+ -- | Returns the contents of the given module or record.  moduleContents@@ -1177,6 +1200,7 @@      --   names paired up with corresponding types.  moduleContents norm rng s = traceCall ModuleContents $ do+  if null (trim s) then getModuleContents norm Nothing else do   e <- parseExpr rng s   case isQName e of     -- If the expression is not a single identifier, it is not a module name@@ -1186,7 +1210,7 @@     -- as a record name.     Just x  -> do       ms :: [AbstractModule] <- scopeLookup x <$> getScope-      if null ms then getRecordContents norm e else getModuleContents norm x+      if null ms then getRecordContents norm e else getModuleContents norm $ Just x  -- | Returns the contents of the given record identifier. @@ -1214,7 +1238,7 @@         , "  cxt  = " TP.<+> (prettyTCM =<< getContextTelescope)         , "  tel  = " TP.<+> prettyTCM tel         , "  doms = " TP.<+> prettyTCM doms-        , "  doms'= " TP.<+> (addContext tel $ prettyTCM doms)+        , "  doms'= " TP.<+> addContext tel (prettyTCM doms)         ]       ts <- mapM (normalForm norm . unDom) doms       return ([], tel, zip xs ts)@@ -1223,14 +1247,18 @@ -- | Returns the contents of the given module.  getModuleContents-  :: Rewrite  -- ^ Amount of normalization in types.-  -> C.QName  -- ^ Module name.+  :: Rewrite+       -- ^ Amount of normalization in types.+  -> Maybe C.QName+       -- ^ Module name, @Nothing@ if top-level module.   -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])-              -- ^ Module names,-              --   context extension,-              --   names paired up with corresponding types.-getModuleContents norm m = do-  modScope <- getNamedScope . amodName =<< resolveModule m+       -- ^ Module names,+       --   context extension,+       --   names paired up with corresponding types.+getModuleContents norm mm = do+  modScope <- case mm of+    Nothing -> getCurrentScope+    Just m  -> getNamedScope . amodName =<< resolveModule m   let modules :: ThingsInScope AbstractModule       modules = exportedNamesInScope modScope       names :: ThingsInScope AbstractName

src/full/Agda/Interaction/CommandLine.hs view

@@ -1,18 +1,25 @@ -module Agda.Interaction.CommandLine where+module Agda.Interaction.CommandLine+  ( runInteractionLoop+  ) where +import Control.Monad.Except+import Control.Monad.State import Control.Monad.Reader  import qualified Data.List as List import Data.Maybe +import Text.Read (readMaybe)+ import Agda.Interaction.Base hiding (Command) import Agda.Interaction.BasicOps as BasicOps hiding (parseExpr)+import Agda.Interaction.Imports ( CheckResult, crInterface ) import Agda.Interaction.Monad  import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common-import Agda.Syntax.Internal (telToList)+import Agda.Syntax.Internal (telToList, alwaysUnblock) import qualified Agda.Syntax.Internal as I import Agda.Syntax.Parser import Agda.Syntax.Position@@ -20,7 +27,6 @@ import Agda.Syntax.Translation.ConcreteToAbstract import Agda.Syntax.Abstract.Pretty -import Agda.TheTypeChecker import Agda.TypeChecking.Constraints import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce@@ -29,23 +35,52 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Warnings (runPM) -import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Monad+import Agda.Utils.FileName (absolute, AbsolutePath)+import Agda.Utils.Maybe (caseMaybeM) import Agda.Utils.Pretty  import Agda.Utils.Impossible +data ReplEnv = ReplEnv+    { replSetupAction     :: TCM ()+    , replTypeCheckAction :: AbsolutePath -> TCM CheckResult+    }++data ReplState = ReplState+    { currentFile :: Maybe AbsolutePath+    }++newtype ReplM a = ReplM { unReplM :: ReaderT ReplEnv (StateT ReplState IM) a }+    deriving+    ( Functor, Applicative, Monad, MonadIO+    , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM+    , MonadError TCErr+    , MonadReader ReplEnv, MonadState ReplState+    )++runReplM :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> ReplM () -> TCM ()+runReplM initialFile setup checkInterface+    = runIM+    . flip evalStateT (ReplState initialFile)+    . flip runReaderT replEnv+    . unReplM+  where+  replEnv = ReplEnv+    { replSetupAction     = setup+    , replTypeCheckAction = checkInterface+    }+ data ExitCode a = Continue | ContinueIn TCEnv | Return a -type Command a = (String, [String] -> TCM (ExitCode a))+type Command a = (String, [String] -> ReplM (ExitCode a)) -matchCommand :: String -> [Command a] -> Either [String] ([String] -> TCM (ExitCode a))+matchCommand :: String -> [Command a] -> Either [String] ([String] -> ReplM (ExitCode a)) matchCommand x cmds =     case List.filter (List.isPrefixOf x . fst) cmds of         [(_,m)] -> Right m         xs      -> Left $ List.map fst xs -interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> IM a+interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> ReplM a interaction prompt cmds eval = loop     where         go (Return x)       = return x@@ -53,43 +88,57 @@         go (ContinueIn env) = localTC (const env) loop          loop =-            do  ms <- readline prompt+            do  ms <- ReplM $ lift $ lift $ readline prompt                 case fmap words ms of                     Nothing               -> return $ error "** EOF **"                     Just []               -> loop                     Just ((':':cmd):args) ->                         do  case matchCommand cmd cmds of-                                Right c -> go =<< liftTCM (c args)+                                Right c -> go =<< (c args)                                 Left [] ->                                     do  liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "'"                                         loop                                 Left xs ->-                                    do  liftIO $ putStrLn $ "More than one command match: " ++ concat (List.intersperse ", " xs)+                                    do  liftIO $ putStrLn $ "More than one command match: " +++                                                            List.intercalate ", " xs                                         loop                     Just _ ->                         do  go =<< liftTCM (eval $ fromJust ms)             `catchError` \e ->-                do  s <- liftTCM $ prettyError e+                do  s <- prettyError e                     liftIO $ putStrLn s                     loop +runInteractionLoop :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()+runInteractionLoop initialFile setup check = runReplM initialFile setup check interactionLoop++replSetup :: ReplM ()+replSetup = do+    liftTCM =<< asks replSetupAction+    liftIO $ putStr splashScreen++checkCurrentFile :: ReplM (Maybe CheckResult)+checkCurrentFile = traverse checkFile =<< gets currentFile++checkFile :: AbsolutePath -> ReplM CheckResult+checkFile file = liftTCM . ($ file) =<< asks replTypeCheckAction+ -- | The interaction loop.-interactionLoop :: TCM (Maybe Interface) -> IM ()-interactionLoop doTypeCheck =-    do  liftTCM reload-        interaction "Main> " commands evalTerm+interactionLoop :: ReplM ()+interactionLoop = do+    -- Run the setup action+    replSetup+    reload+    interaction "Main> " commands evalTerm     where-        reload = do-            mi <- doTypeCheck-            -- Note that mi is Nothing if (1) there is no input file or-            -- (2) the file type checked with unsolved metas and-            -- --allow-unsolved-metas was used. In the latter case the-            -- behaviour of agda -I may be surprising. If agda -I ever-            -- becomes properly supported again, then this behaviour-            -- should perhaps be fixed.-            setScope $ case mi of-              Just i  -> iInsideScope i-              Nothing -> emptyScopeInfo+        reload :: ReplM () = do+            checked <- checkCurrentFile+            liftTCM $ setScope $ maybe emptyScopeInfo iInsideScope (crInterface <$> checked)+            -- 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 <- prettyError e             liftIO $ putStrLn s@@ -100,34 +149,35 @@             , "?"           |>  \_ -> continueAfter $ liftIO $ help commands             , "reload"      |>  \_ -> do reload                                          ContinueIn <$> askTC-            , "constraints" |> \args -> continueAfter $ showConstraints args-            , "Context"     |> \args -> continueAfter $ showContext args-            , "give"        |> \args -> continueAfter $ giveMeta args-            , "Refine"      |> \args -> continueAfter $ refineMeta args-            , "metas"       |> \args -> continueAfter $ showMetas args+            , "constraints" |> \args -> continueAfter $ liftTCM $ showConstraints args+            , "Context"     |> \args -> continueAfter $ liftTCM $ showContext args+            , "give"        |> \args -> continueAfter $ liftTCM $ giveMeta args+            , "Refine"      |> \args -> continueAfter $ liftTCM $ refineMeta args+            , "metas"       |> \args -> continueAfter $ liftTCM $ showMetas args             , "load"        |> \args -> continueAfter $ loadFile reload args-            , "eval"        |> \args -> continueAfter $ evalIn args-            , "typeOf"      |> \args -> continueAfter $ typeOf args-            , "typeIn"      |> \args -> continueAfter $ typeIn args-            , "wakeup"      |> \_ -> continueAfter $ retryConstraints-            , "scope"       |> \_ -> continueAfter $ showScope+            , "eval"        |> \args -> continueAfter $ liftTCM $ evalIn args+            , "typeOf"      |> \args -> continueAfter $ liftTCM $ typeOf args+            , "typeIn"      |> \args -> continueAfter $ liftTCM $ typeIn args+            , "wakeup"      |> \_ -> continueAfter $ liftTCM $ retryConstraints+            , "scope"       |> \_ -> continueAfter $ liftTCM $ showScope             ]             where                 (|>) = (,) -continueAfter :: TCM a -> TCM (ExitCode b)+continueAfter :: ReplM a -> ReplM (ExitCode b) continueAfter m = withCurrentFile $ do   m >> return Continue --- | Set 'envCurrentPath' to 'optInputFile'.-withCurrentFile :: TCM a -> TCM a+-- | Set 'envCurrentPath' to the repl's current file+withCurrentFile :: ReplM a -> ReplM a withCurrentFile cont = do-  mpath <- getInputFile'+  mpath <- gets currentFile   localTC (\ e -> e { envCurrentPath = mpath }) cont -loadFile :: TCM () -> [String] -> TCM ()+loadFile :: ReplM () -> [String] -> ReplM () loadFile reload [file] = do-  setInputFile file+  absPath <- liftIO $ absolute file+  modify (\(ReplState _prevFile) -> ReplState (Just absPath))   withCurrentFile reload loadFile _ _ = liftIO $ putStrLn ":load file" @@ -145,21 +195,21 @@           s <- typeOfMeta AsIs i           r <- getInteractionRange i           d <- prettyA s-          liftIO $ putStrLn $ show d ++ " " ++ show r+          liftIO $ putStrLn $ render d ++ " " ++ prettyShow r showMetas [m,"normal"] =     do  i <- InteractionId <$> readM m         withInteractionId i $ do           s <- prettyA =<< typeOfMeta Normalised i           r <- getInteractionRange i-          liftIO $ putStrLn $ show s ++ " " ++ show r+          liftIO $ putStrLn $ render s ++ " " ++ prettyShow r showMetas [] =     do  interactionMetas <- typesOfVisibleMetas AsIs         hiddenMetas      <- typesOfHiddenMetas  AsIs         mapM_ (liftIO . print) =<< mapM showII interactionMetas         mapM_ print' hiddenMetas     where-        showII o = withInteractionId (outputFormId $ OutputForm noRange [] o) $ prettyA o-        showM  o = withMetaId (nmid $ outputFormId $ OutputForm noRange [] o) $ prettyA o+        showII o = withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock o) $ prettyA o+        showM  o = withMetaId (nmid $ outputFormId $ OutputForm noRange [] alwaysUnblock o) $ prettyA o          metaId (OfType i _) = i         metaId (JustType i) = i@@ -169,24 +219,22 @@         print' x = do             r <- getMetaRange $ nmid $ metaId x             d <- showM x-            liftIO $ putStrLn $ show d ++ "  [ at " ++ show r ++ " ]"+            liftIO $ putStrLn $ render d ++ "  [ at " ++ prettyShow r ++ " ]" showMetas _ = liftIO $ putStrLn $ ":meta [metaid]"   showScope :: TCM () showScope = do   scope <- getScope-  liftIO $ print scope+  liftIO $ putStrLn $ prettyShow scope  metaParseExpr ::  InteractionId -> String -> TCM A.Expr metaParseExpr ii s =     do  m <- lookupInteractionId ii         scope <- getMetaScope <$> lookupMeta m         r <- getRange <$> lookupMeta m-        --liftIO $ putStrLn $ show scope-        let pos = case rStart r of-                    Nothing  -> __IMPOSSIBLE__-                    Just pos -> pos+        -- liftIO $ putStrLn $ prettyShow scope+        let pos = fromMaybe __IMPOSSIBLE__ (rStart r)         e <- runPM $ parsePosString exprParser pos s         concreteToAbstract scope e @@ -216,12 +264,12 @@   retryConstraints :: TCM ()-retryConstraints = liftTCM wakeupConstraints_+retryConstraints = wakeupConstraints_   evalIn :: [String] -> TCM () evalIn s | length s >= 2 =-    do  d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent e+    do  d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent DefaultCompute e         liftIO $ print d evalIn _ = liftIO $ putStrLn ":eval metaid expr" @@ -233,17 +281,11 @@ evalTerm :: String -> TCM (ExitCode a) evalTerm s =     do  e <- parseExpr s-        v <- evalInCurrent e+        v <- evalInCurrent DefaultCompute e         e <- prettyTCM v-        liftIO $ putStrLn $ show e+        liftIO $ print e         return Continue-    where-        evalInCurrent e = do-          (v,t) <- inferExpr e-          v'    <- normalise v-          return v' - typeOf :: [String] -> TCM () typeOf s =     do  e  <- parseExpr (unwords s)@@ -299,3 +341,11 @@     [ "<exp> Infer type of expression <exp> and evaluate it." ]     where         explain (x,_) = ":" ++ x++-- Read -------------------------------------------------------------------++readM :: Read a => String -> TCM a+readM s = maybe err return $ readMaybe s+  where+  err    = throwError $ strMsg $ "Cannot parse: " ++ s+  strMsg = Exception noRange . text

src/full/Agda/Interaction/EmacsCommand.hs view

@@ -37,14 +37,14 @@   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+-- 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. --

src/full/Agda/Interaction/EmacsTop.hs view

@@ -17,7 +17,7 @@ import Agda.Syntax.Abstract as A import Agda.Syntax.Concrete as C -import Agda.TypeChecking.Errors (prettyError)+import Agda.TypeChecking.Errors (prettyError, getAllWarningsOfTCErr) import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Pretty (prettyTCM) import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings, prettyTCWarnings')@@ -31,8 +31,6 @@ import Agda.Interaction.Highlighting.Emacs import Agda.Interaction.Highlighting.Precise (TokenBased(..)) import Agda.Interaction.InteractionTop (localStateCommandM)-import Agda.Interaction.Imports (getAllWarningsOfTCErr)-import Agda.Utils.Impossible (__IMPOSSIBLE__) import Agda.Utils.Function (applyWhen) import Agda.Utils.Null (empty) import Agda.Utils.Maybe@@ -49,7 +47,7 @@ --   'mimicGHCi' reads the Emacs frontend commands from stdin, --   interprets them and print the result into stdout. mimicGHCi :: TCM () -> TCM ()-mimicGHCi = repl (liftIO . mapM_ print <=< lispifyResponse) "Agda2> "+mimicGHCi = repl (liftIO . mapM_ (putStrLn . prettyShow) <=< lispifyResponse) "Agda2> "  -- | Convert Response to an elisp value for the interactive emacs frontend. @@ -72,12 +70,13 @@   | 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])+                 , A (quote $ List.intercalate "," $ catMaybes [checked, showImpl, showIrr])                  ]              ]   where-    checked  = boolToMaybe (sChecked               s) "Checked"-    showImpl = boolToMaybe (sShowImplicitArguments s) "ShowImplicit"+    checked  = boolToMaybe (sChecked                 s) "Checked"+    showImpl = boolToMaybe (sShowImplicitArguments   s) "ShowImplicit"+    showIrr  = boolToMaybe (sShowIrrelevantArguments s) "ShowIrrelevant"  lispifyResponse (Resp_JumpToError f p) = return   [ lastTag 3 $@@ -133,7 +132,9 @@     Info_NormalForm state cmode time expr -> do       exprDoc <- evalStateT prettyExpr state       let doc = maybe empty prettyTimed time $$ exprDoc-      format (render doc) "*Normal Form*"+          lbl | cmode == HeadCompute = "*Head Normal Form*"+              | otherwise            = "*Normal Form*"+      format (render doc) lbl       where         prettyExpr = localStateCommandM             $ lift@@ -339,6 +340,7 @@      pKind = \case       ConName                  -> "constructor"+      CoConName                -> "coinductive constructor"       FldName                  -> "record field"       PatternSynName           -> "pattern synonym"       GeneralizeName           -> "generalizable variable"@@ -425,7 +427,7 @@       maybeVal <- traverse prettyATop letv        return $-        [ (attribute ++ prettyCtxName, ":" <+> ty <+> (parenSep extras)) ] +++        (attribute ++ prettyCtxName, ":" <+> ty <+> (parenSep extras)) :         [ (prettyShow x, "=" <+> val) | val <- maybeToList maybeVal ]    where

+ src/full/Agda/Interaction/ExitCode.hs view

@@ -0,0 +1,34 @@++module Agda.Interaction.ExitCode (+  AgdaError(..),+  agdaErrorToInt,+  agdaErrorFromInt,+  exitSuccess,+  exitAgdaWith)+  where++import System.Exit (exitSuccess, exitWith, ExitCode(ExitFailure))++data AgdaError = UnknownError      -- ^ 1+               | TCMError          -- ^ 42+               | OptionError       -- ^ 71+               | ImpossibleError   -- ^ 154+               deriving (Show, Eq, Enum, Bounded)++agdaErrorToInt :: AgdaError -> Int+agdaErrorToInt UnknownError    = 1+agdaErrorToInt TCMError        = 42+agdaErrorToInt OptionError     = 71+agdaErrorToInt ImpossibleError = 154++-- ^ Return the error corresponding to an exit code from the+--   Agda process+agdaErrorFromInt :: Int -> Maybe AgdaError+agdaErrorFromInt = -- We implement this in a somewhat more inefficient+                   -- way for the sake of consistency+                   flip lookup [(agdaErrorToInt error, error)+                               | error  <- [minBound..maxBound]+                               ]++exitAgdaWith :: AgdaError -> IO ()+exitAgdaWith = exitWith . ExitFailure . agdaErrorToInt

src/full/Agda/Interaction/FindFile.hs view

@@ -21,8 +21,8 @@ import Prelude hiding (null)  import Control.Monad+import Control.Monad.Except import Control.Monad.Trans-import qualified Data.List as List import Data.Maybe (catMaybes) import qualified Data.Map as Map import System.FilePath@@ -39,15 +39,21 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Benchmark (billTo) import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Monad.Options (getIncludeDirs, libToTCM) import Agda.TypeChecking.Warnings (runPM) +import Agda.Version ( version )+ import Agda.Utils.Applicative ( (?$>) )-import Agda.Utils.Except import Agda.Utils.FileName-import Agda.Utils.List ( stripSuffix, nubOn )-import Agda.Utils.Monad ( ifM )+import Agda.Utils.List  ( stripSuffix, nubOn )+import Agda.Utils.List1 ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Monad ( ifM, unlessM )+import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Singleton+ import Agda.Utils.Impossible-import Agda.Version ( version )  -- | Type aliases for source files and interface files. --   We may only produce one of these if we know for sure that the file@@ -76,7 +82,7 @@   let fp = filePath src   mroot <- ifM (optLocalInterfaces <$> commandLineOptions)                {- then -} (pure Nothing)-               {- else -} (liftIO $ findProjectRoot $ takeDirectory fp)+               {- else -} (libToTCM $ findProjectRoot (takeDirectory fp))   pure $ replaceModuleExtension ".agdai" $ case mroot of     Nothing   -> src     Just root ->@@ -194,7 +200,7 @@   -> Maybe TopLevelModuleName      -- ^ The expected name, coming from an import statement.   -> TCM ()-checkModuleName name (SourceFile file) mexpected =+checkModuleName name (SourceFile file) mexpected = do   findFile' name >>= \case      Left (NotFound files)  -> typeError $@@ -208,11 +214,21 @@     Right src -> do       let file' = srcFilePath src       file <- liftIO $ absolute (filePath file)-      if file === file' then-        return ()-       else+      unlessM (liftIO $ sameFile file file') $         typeError $ ModuleDefinedInOtherFile name file file' +  -- Andreas, 2020-09-28, issue #4671:  In any case, make sure+  -- that we do not end up with a mismatch between expected+  -- and actual module name.++  forM_ mexpected $ \ expected ->+    unless (name == expected) $+      typeError $ OverlappingProjects file name expected+      -- OverlappingProjects is the correct error for+      -- test/Fail/customized/NestedProjectRoots+      -- -- typeError $ ModuleNameUnexpected name expected++ -- | Computes the module name of the top-level module in the given -- file. --@@ -230,26 +246,26 @@   -> TCM TopLevelModuleName moduleName file parsedModule = billTo [Bench.ModuleName] $   case moduleNameParts name of-    ["_"] -> do+    "_" :| [] -> do       m <- runPM (parse moduleNameParser defaultName)              `catchError` \_ ->            typeError $ GenericError $-             "The file name " ++ show file +++             "The file name " ++ prettyShow file ++              " is invalid because it does not correspond to a valid module name."       case m of         Qual {} ->           typeError $ GenericError $-            "The file name " ++ show file ++ " is invalid because " +++            "The file name " ++ prettyShow file ++ " is invalid because " ++             defaultName ++ " is not an unqualified module name."         QName {} ->-          return $ TopLevelModuleName (getRange m) [defaultName]+          return $ TopLevelModuleName (getRange m) $ singleton defaultName     _ -> return name   where   name        = topLevelModuleName parsedModule   defaultName = rootNameModule file  parseFileExtsShortList :: [String]-parseFileExtsShortList = [".agda"] ++ literateExtsShortList+parseFileExtsShortList = ".agda" : literateExtsShortList  dropAgdaExtension :: String -> String dropAgdaExtension s = case catMaybes [ stripSuffix ext s

src/full/Agda/Interaction/Highlighting/Common.hs view

@@ -38,7 +38,7 @@   :: HighlightingInfo   -> HighlightingMethod   -> HighlightingMethod-chooseHighlightingMethod info method = case ranges info of+chooseHighlightingMethod info method = case toList info of   _             | method == Direct -> Direct   ((_, mi) : _) | check mi         -> Direct   _                                -> Indirect

src/full/Agda/Interaction/Highlighting/Dot.hs view

@@ -1,96 +1,5 @@---- | Generate an import dependency graph for a given module.--module Agda.Interaction.Highlighting.Dot where--import Control.Monad.State--import qualified Data.Map as M-import Data.Map(Map)-import Data.Maybe--import qualified Data.Set as S-import Data.Set (Set)--import Agda.Interaction.Options-import Agda.Syntax.Abstract-import Agda.TypeChecking.Monad--import Agda.Utils.Impossible---- | Internal module identifiers for construction of dependency graph.-type ModuleId = String--data DotState = DotState-  { dsModules    :: Map ModuleName ModuleId-    -- ^ Records already processed modules-    --   and maps them to an internal identifier.-  , dsNameSupply :: [ModuleId]-    -- ^ Supply of internal identifiers.-  , dsConnection :: Set (ModuleId, ModuleId)-    -- ^ Edges of dependency graph.-  }--initialDotState :: DotState-initialDotState = DotState-  { dsModules    = mempty-  , dsNameSupply = map (('m':) . show) [0..]-  , dsConnection = mempty-  }--type DotM = StateT DotState TCM---- | Translate a 'ModuleName' to an internal 'ModuleId'.---   Returns @True@ if the 'ModuleName' is new, i.e., has not been---   encountered before and is thus added to the map of processed modules.-addModule :: ModuleName -> DotM (ModuleId, Bool)-addModule m = do-    s <- get-    case M.lookup m (dsModules s) of-        Just r  -> return (r, False)-        Nothing -> do-            let newName:nameSupply = dsNameSupply s-            put s-              { dsModules = M.insert m newName (dsModules s)-              , dsNameSupply = nameSupply-              }-            return (newName, True)---- | Add an arc from importer to imported.-addConnection :: ModuleId -> ModuleId -> DotM ()-addConnection m1 m2 = modify $ \s -> s {dsConnection = S.insert (m1,m2) (dsConnection s)}---- | Recursively build import graph, starting from given 'Interface'.---   Modifies the state in 'DotM' and returns the 'ModuleId' of the 'Interface'.-dottify :: Interface -> DotM ModuleId-dottify inter = do-    let curModule = iModuleName inter-    (name, continue) <- addModule curModule-    -- If we have not visited this interface yet,-    -- process its imports recursively and-    -- add them as connections to the graph.-    when continue $ do-        importsifs <- lift $ map miInterface . catMaybes <$>-          mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules inter)-        imports    <- mapM dottify importsifs-        mapM_ (addConnection name) imports-    return name+module Agda.Interaction.Highlighting.Dot+  ( dotBackend+  ) where --- | Generate a .dot file for the import graph starting with the---   given 'Interface' and write it to the file specified by the---   command line option.-generateDot :: Interface -> TCM ()-generateDot inter = do-    (top, state) <- flip runStateT initialDotState $ do-        dottify inter-    fp <- fromMaybe __IMPOSSIBLE__ . optDependencyGraph <$> commandLineOptions-    liftIO $ writeFile fp $ mkDot state-  where-    mkDot :: DotState -> String-    mkDot st = unlines $-        [ "digraph dependencies {"-        ] ++ ["   " ++ repr ++ "[label=\"" ++ show (mnameToConcrete modulename) ++ "\"];"-             | (modulename, repr) <- M.toList (dsModules st)]-          ++ ["   " ++ r1 ++ " -> " ++ r2 ++ ";"-             | (r1 , r2) <- S.toList (dsConnection st) ]-          ++ ["}"]+import Agda.Interaction.Highlighting.Dot.Backend ( dotBackend )

+ src/full/Agda/Interaction/Highlighting/Dot/Backend.hs view

@@ -0,0 +1,160 @@++module Agda.Interaction.Highlighting.Dot.Backend+  ( dotBackend+  ) where++import Agda.Interaction.Highlighting.Dot.Base+  ( dottify+  , renderDotToFile+  , Env(Env, deConnections, deLabel)+  )++import Control.Monad.Except+  ( MonadIO+  , ExceptT+  , runExceptT+  , MonadError(throwError)+  )++import Control.DeepSeq++import Data.Map ( Map )+import Data.Set ( Set )+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe+import qualified Data.Text.Lazy as L++import GHC.Generics (Generic)++import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..))+import Agda.Compiler.Common (curIF, IsMain)++import Agda.Interaction.Options+  ( ArgDescr(ReqArg)+  , Flag+  , OptDescr(..)+  )++import Agda.Syntax.Abstract ( ModuleName )++import Agda.TypeChecking.Monad+  ( Interface(iImportedModules, iModuleName)+  , MonadTCError+  , ReadTCState+  , genericError+  )++import Agda.Utils.Pretty ( prettyShow )++-- ------------------------------------------------------------------------++data DotFlags = DotFlags+  { dotFlagDestination :: Maybe FilePath+  } deriving (Eq, Generic)++instance NFData DotFlags++defaultDotFlags :: DotFlags+defaultDotFlags = DotFlags+  { dotFlagDestination = Nothing+  }++dotFlagsDescriptions :: [OptDescr (Flag DotFlags)]+dotFlagsDescriptions =+  [ Option [] ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")+              "generate a Dot file with a module dependency graph"+  ]++dependencyGraphFlag :: FilePath -> Flag DotFlags+dependencyGraphFlag f o = return $ o { dotFlagDestination = Just f }++data DotCompileEnv = DotCompileEnv+  { _dotCompileEnvDestination :: FilePath+  }++-- Currently unused+data DotModuleEnv = DotModuleEnv++data DotModule = DotModule+  { _dotModuleName :: ModuleName+  , dotModuleImportedNames :: Set ModuleName+  }++-- | Currently unused+data DotDef = DotDef++dotBackend :: Backend+dotBackend = Backend dotBackend'++dotBackend' :: Backend' DotFlags DotCompileEnv DotModuleEnv DotModule DotDef+dotBackend' = Backend'+  { backendName           = "Dot"+  , backendVersion        = Nothing+  , options               = defaultDotFlags+  , commandLineFlags      = dotFlagsDescriptions+  , isEnabled             = isJust . dotFlagDestination+  , preCompile            = asTCErrors . preCompileDot+  , preModule             = preModuleDot+  , compileDef            = compileDefDot+  , postModule            = postModuleDot+  , postCompile           = postCompileDot+  , scopeCheckingSuffices = True+  , mayEraseType          = const $ return True+  }++-- | Convert a general "MonadError String m" into "MonadTCError m".+asTCErrors :: MonadTCError m => ExceptT String m b -> m b+asTCErrors t = either genericError return =<< runExceptT t++preCompileDot+  :: MonadError String m+  => DotFlags+  -> m DotCompileEnv+preCompileDot (DotFlags (Just dest)) = return $ DotCompileEnv dest+preCompileDot (DotFlags Nothing)     = throwError "The Dot backend was invoked without being enabled!"++preModuleDot+  :: Applicative m+  => DotCompileEnv+  -> IsMain+  -> ModuleName+  -> Maybe FilePath+  -> m (Recompile DotModuleEnv DotModule)+preModuleDot _cenv _main _moduleName _ifacePath = pure $ Recompile DotModuleEnv++compileDefDot+  :: Applicative m+  => DotCompileEnv+  -> DotModuleEnv+  -> IsMain+  -> Definition+  -> m DotDef+compileDefDot _cenv _menv _main _def = pure DotDef++postModuleDot+  :: (MonadIO m, ReadTCState m)+  => DotCompileEnv+  -> DotModuleEnv+  -> IsMain+  -> ModuleName+  -> [DotDef]+  -> m DotModule+postModuleDot _cenv DotModuleEnv _main moduleName _defs = do+  i <- curIF+  let importedModuleNames = Set.fromList $ fst <$> (iImportedModules i)+  return $ DotModule moduleName importedModuleNames++postCompileDot+  :: (MonadIO m, ReadTCState m)+  => DotCompileEnv+  -> IsMain+  -> Map ModuleName DotModule+  -> m ()+postCompileDot (DotCompileEnv fp) _main modulesByName = do+  let env = Env+        { deConnections = (maybe [] (Set.toList . dotModuleImportedNames) . (flip Map.lookup modulesByName))+        , deLabel       = L.pack . prettyShow+        }+  dot <- dottify env . iModuleName <$> curIF+  renderDotToFile dot fp

+ src/full/Agda/Interaction/Highlighting/Dot/Base.hs view

@@ -0,0 +1,128 @@+{-# LANGUAGE GADTs #-}+-- | Generate an import dependency graph for a given module.++module Agda.Interaction.Highlighting.Dot.Base+  ( dottify+  , renderDotToFile+  , renderDot+  , DotGraph (..)+  , Env(..)+  ) where++import Control.Monad.Reader+import Control.Monad.State++import qualified Data.Map as M+import Data.Map(Map)++import qualified Data.Set as S+import Data.Set (Set)++import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Encoding as E+import qualified Data.ByteString.Lazy as BS++-- | Internal module identifiers for construction of dependency graph.+type NodeId = L.Text++-- | Graph structure+data DotGraph = DotGraph+  { dgNodeLabels :: Map NodeId L.Text+  , dgEdges      :: Set (NodeId, NodeId)+  }++-- * Graph construction monad++-- Read-only environment when constructing the graph.+data Env n where+  Env :: Ord n =>+    { deConnections :: n -> [n]+    -- ^ Names connected to an entity+    , deLabel       :: n -> L.Text+    -- ^ Rendering that entity's name to a label+    } -> Env n++data DotState n = DotState+  { dsNodeIds      :: Map n NodeId+    -- ^ Records already processed entities+    --   and maps them to an internal identifier.+  , dsNodeIdSupply :: [NodeId]+    -- ^ Supply of internal identifiers.+  , dsGraph        :: DotGraph+  }++initialDotState :: DotState n+initialDotState = DotState+  { dsNodeIds      = M.empty+  , dsNodeIdSupply = map (L.pack . ('m':) . show) [0..]+  , dsGraph        = DotGraph mempty mempty+  }++type DotM n a = ReaderT (Env n) (State (DotState n)) a++runDotM :: Env n -> DotM n x -> DotGraph+runDotM env@Env{} = dsGraph . flip execState initialDotState . flip runReaderT env++getLabel :: n -> DotM n L.Text+getLabel = liftM2 deLabel ask . pure++getConnections :: n -> DotM n [n]+getConnections = liftM2 deConnections ask . pure++-- | Translate an entity name into an internal 'NodeId'.+--   Returns @True@ if the 'ModuleName' is new, i.e., has not been+--   encountered before and is thus added to the map of processed modules.+addEntity :: Ord n => n -> DotM n (NodeId, Bool)+addEntity name = do+    s@(DotState nodeIds nodeIdSupply graph) <- get+    case M.lookup name nodeIds of+        Just nodeId  -> return (nodeId, False)+        Nothing -> do+            let newNodeId:remainingNodeIdSupply = nodeIdSupply+            label <- getLabel name+            put s+              { dsNodeIds      = M.insert name newNodeId nodeIds+              , dsNodeIdSupply = remainingNodeIdSupply+              , dsGraph        = graph+                { dgNodeLabels = M.insert newNodeId label . dgNodeLabels $ graph+                }+              }+            return (newNodeId, True)++-- | Add an arc from importer to imported.+addConnection :: NodeId -> NodeId -> DotM n ()+addConnection m1 m2 = modify $ \s -> s+  { dsGraph = (dsGraph s)+    { dgEdges = S.insert (m1, m2) . dgEdges . dsGraph $ s+    }+  }++dottify :: Ord n => Env n -> n -> DotGraph+dottify env root = runDotM env (dottify' root)++dottify' :: Ord n => n -> DotM n NodeId+dottify' entity = do+  (nodeId, continue) <- addEntity entity+  -- If we have not visited this interface yet,+  -- process its imports recursively and+  -- add them as connections to the graph.+  when continue $ do+    connectedEntities <- getConnections entity+    connectedNodeIds <- mapM dottify' connectedEntities+    mapM_ (addConnection nodeId) connectedNodeIds+  return nodeId++-- * Graph rendering++renderDot :: DotGraph -> L.Text+renderDot g = L.unlines $ concat+  [ [ "digraph dependencies {" ]+  , [ L.concat ["   ", nodeId, "[label=\"", label, "\"];"]+    | (nodeId, label) <- M.toList (dgNodeLabels g) ]+  , [ L.concat ["   ", r1, " -> ", r2, ";"]+    | (r1 , r2) <- S.toList (dgEdges g) ]+  , ["}"]+  ]++renderDotToFile :: MonadIO m => DotGraph -> FilePath -> m ()+renderDotToFile dot fp = liftIO $ BS.writeFile fp $ E.encodeUtf8 $ renderDot dot

src/full/Agda/Interaction/Highlighting/Emacs.hs view

@@ -6,6 +6,8 @@   , lispifyTokenBased   ) where +import Prelude hiding (null)+ import Agda.Interaction.Highlighting.Common import Agda.Interaction.Highlighting.Precise import Agda.Interaction.Highlighting.Range (Range(..))@@ -14,12 +16,14 @@ import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource) import Agda.Utils.FileName (filePath) import Agda.Utils.IO.TempFile (writeToTempFile)+import Agda.Utils.Pretty (prettyShow) import Agda.Utils.String (quote)  import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe +import Agda.Utils.Null import Agda.Utils.Impossible  ------------------------------------------------------------------------@@ -40,9 +44,9 @@     dropNils (       [lispifyTokenBased (tokenBased m)]         ++-      [A $ maybe "nil" quote $ note m]+      [A $ ifNull (note m) "nil" quote]         ++-      (maybeToList $ fmap defSite $ definitionSite m))+      maybeToList (defSite <$> definitionSite m))   where   defSite (DefinitionSite m p _ _) =     Cons (A $ quote $ filePath f) (A $ show p)@@ -81,7 +85,7 @@   info = (case remove of                 RemoveHighlighting -> A "remove"                 KeepHighlighting   -> A "nil") :-             map (showAspects modFile) (ranges h)+             map (showAspects modFile) (toList h)    direct :: IO (Lisp String)   direct = return $ L (A "agda2-highlight-add-annotations" :@@ -89,7 +93,7 @@    indirect :: IO (Lisp String)   indirect = do-    filepath <- writeToTempFile (show $ L info)+    filepath <- writeToTempFile (prettyShow $ L info)     return $ L [ A "agda2-highlight-load-and-delete-action"                , A (quote filepath)                ]

+ src/full/Agda/Interaction/Highlighting/FromAbstract.hs view

@@ -0,0 +1,699 @@+-- | Extract highlighting syntax from abstract syntax.+--+-- 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   #-}++module Agda.Interaction.Highlighting.FromAbstract+  ( runHighlighter+  , NameKinds+  ) where++import Prelude hiding (null)++import Control.Applicative+import Control.Monad.Reader++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 qualified Agda.Syntax.Abstract      as A+import           Agda.Syntax.Common        as Common+import           Agda.Syntax.Concrete                ( FieldAssignment'(..) )+import qualified Agda.Syntax.Concrete.Name as C+import           Agda.Syntax.Info                    ( ModuleInfo(..) )+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.TypeChecking.Monad+  hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype)++import           Agda.Utils.FileName+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+import           Agda.Utils.Maybe+import qualified Agda.Utils.Maybe.Strict   as Strict+import           Agda.Utils.Pretty+import           Agda.Utils.Singleton++-- Entry point:+-- | Create highlighting info for some piece of syntax.+runHighlighter ::+  Hilite a =>+  SourceToModule -> AbsolutePath -> NameKinds -> a ->+  HighlightingInfoBuilder+runHighlighter modMap fileName kinds x =+  runReader (hilite x) $+  HiliteEnv+    { hleNameKinds = kinds+    , hleModMap    = modMap+    , hleFileName  = fileName+    }++-- | Environment of the highlighter.+data HiliteEnv = HiliteEnv+  { hleNameKinds :: NameKinds+      -- ^ Function mapping qualified names to their kind.+  , hleModMap    :: SourceToModule+      -- ^ Maps source file paths to module names.+  , hleFileName  :: AbsolutePath+      -- ^ The file name of the current module. Used for consistency checking.+  }++-- | A function mapping names to the kind of name they stand for.+type NameKinds = A.QName -> Maybe NameKind++-- | Highlighting monad.+type HiliteM = Reader HiliteEnv++-- | Highlighter.++type Hiliter = HiliteM HighlightingInfoBuilder++instance Monoid Hiliter where+  mempty  = pure mempty+  mappend = (<>)++-- | Traversal to extract highlighting information.++class Hilite a where+  hilite :: a -> Hiliter++  default hilite :: (Foldable t, Hilite b, t b ~ a) => a -> Hiliter+  hilite = foldMap hilite++-- * Generic instances+---------------------------------------------------------------------------++instance Hilite a => Hilite [a]+instance Hilite a => Hilite (List1 a)+instance Hilite a => Hilite (Maybe a)+instance Hilite a => Hilite (WithHiding a)++instance Hilite Void where+  hilite _ = mempty++instance (Hilite a, Hilite b) => Hilite (Either a b) where+  hilite = either hilite hilite++instance (Hilite a, Hilite b) => Hilite (a, b) where+  hilite (a, b) = hilite a <> hilite b++-- * Major syntactic categories+---------------------------------------------------------------------------++-- | Reengineered from the old Geniplate-implemented highlighting extraction.+-- This was the old procedure:+--+-- Traversal over declaration in abstract syntax that collects the+-- following hiliting information:+--+-- [1. @constructorInfo@ (highest prio)]+-- 2. @theRest@ (medium prio)+-- 3. @nameInfo@ (lowest prio)+--+-- @nameInfo@:+--   "All names mentioned in the syntax tree (not bound variables)."+-- For each possibly ambiguous name (QName and AmbiguousQName)+-- that not isExtendedLambdaName,+-- do @hiliteAmbiguous@ (used to be called@generate@).+--+-- @constructorInfo@ (only when highlighting level == Full):+--   "After the code has been type checked more information may be+--   available for overloaded constructors, and+--   generateConstructorInfo takes advantage of this information.+--   Note, however, that highlighting for overloaded constructors is+--   included also in nameInfo."+-- This is not computed by recursion over the abstract syntax,+-- but gets the constructor names stDisambiguatedNames+-- that fall within the bounds of the current declaration.+--+-- @theRest@:+--   Bound variables, dotted patterns, record fields, module names,+--   the "as" and "to" symbols and some other things.+--+-- Here is a table what @theRest@ used to collect:+--+-- ---------------------------------------------------------------------+-- | A.Expr+-- ---------------------------------------------------------------------+-- | getVarAndField (Expr) | A.Var                       | bound+-- | getVarAndField        | A.Rec(Update)               | field+-- | getExpr        (Expr) | A.PatternSyn                | patsyn+-- | getExpr               | A.Macro                     | macro+-- ---------------------------------------------------------------------+-- | A.LetBinding+-- ---------------------------------------------------------------------+-- | getLet                | A.LetBind                   | bound+-- | getLet                | A.LetDeclaredVariable       | bound+-- ---------------------------------------------------------------------+-- | A.LamBinding+-- ---------------------------------------------------------------------+-- | getLam                | A.Binder under A.DomainFree | bound+-- | getTyped              | A.Binder under A.TBind      | bound+-- ---------------------------------------------------------------------+-- | A.Pattern'+-- ---------------------------------------------------------------------+-- | getPattern(Syn)       | A.VarP                      | bound+-- | getPattern(Syn)       | A.AsP                       | bound+-- | getPattern(Syn)       | A.DotP (not isProjP)        | DottedPattern+-- | getPattern(Syn)       | A.RecP                      | field+-- | getPattern(Syn)       | A.PatternSynP               | patsyn+-- ---------------------------------------------------------------------+-- | A.Declaration+-- ---------------------------------------------------------------------+-- | getFieldDecl          | A.Field under A.RecDef      | field+-- | getPatSynArgs         | A.PatternSynDef             | bound+-- | getPragma             | A.BuiltinPragma...          | keyword+-- ---------------------------------------------------------------------+-- | A.NamedArg (polymorphism not supported in geniplate)+-- ---------------------------------------------------------------------+-- | getNamedArg           | NamedArg a                  | nameOf+-- | getNamedArgE          | NamedArg Exp                | nameOf+-- | getNamedArgP          | NamedArg Pattern            | nameOf+-- | getNamedArgB          | NamedArg BindName           | nameOf+-- | getNamedArgL          | NamedArg LHSCore            | nameOf+--+-- | getModuleName         | A.MName                     | mod+-- | getModuleInfo         | ModuleInfo                  | asName, (range of as,to)+-- | getQuantityAttr       | Common.Quantity             | Symbol (if range)++instance Hilite A.RecordDirectives where+  hilite (RecordDirectives _ _ _ c) = hilite c++instance Hilite A.Declaration where+  hilite = \case+      A.Axiom _ax _di ai _occ x e            -> hl ai <> hl x <> hl e+      A.Generalize _names _di ai x e         -> hl ai <> hl x <> hl e+      A.Field _di x e                        -> hlField x <> hl e+      A.Primitive _di x e                    -> hl x <> hl e+      A.Mutual _mi ds                        -> hl ds+      A.Section _r x tel ds                  -> hl x <> hl tel <> hl ds+      A.Apply mi x a _ci dir                 -> hl mi <> hl x <> hl a <> hl dir+      A.Import mi x dir                      -> hl mi <> hl x <> hl dir+      A.Open mi x dir                        -> hl mi <> hl x <> hl dir+      A.FunDef _di x _delayed cs             -> hl x <> hl cs+      A.DataSig _di x tel e                  -> hl x <> hl tel <> hl e+      A.DataDef _di x _uc pars cs            -> hl x <> hl pars <> hl cs+      A.RecSig _di x tel e                   -> 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.PatternSynDef x xs p                 -> hl x <> hl xs <> hl p+      A.UnquoteDecl _mi _di xs e             -> hl xs <> hl e+      A.UnquoteDef _di xs e                  -> hl xs <> hl e+      A.ScopedDecl s ds                      -> hl ds+      A.Pragma _r pragma                     -> hl pragma+    where+    hl      a = hilite a+    hlField x = hiliteField (concreteQualifier x) (concreteBase x) (Just $ bindingSite x)++instance Hilite A.Pragma where+  hilite = \case+    A.OptionsPragma _strings     -> mempty+    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.RewritePragma r xs         -> singleAspect Keyword r <> hilite xs+    A.StaticPragma x             -> hilite x+    A.EtaPragma x                -> hilite x+    A.InjectivePragma x          -> hilite x+    A.InlinePragma _inline x     -> hilite x+    A.DisplayPragma x ps e       -> hilite x <> hilite ps <> hilite e++instance Hilite A.Expr where+  hilite = \case+      A.Var x                       -> hl $ A.BindName x        -- bound variable like binder+      A.Def' q _                    -> hiliteQName Nothing q+      A.Proj _o qs                  -> hiliteAmbiguousQName Nothing qs  -- Issue #4604: not: hiliteProjection qs+                                         -- Names from @open R r@ should not be highlighted as projections+      A.Con qs                      -> hiliteAmbiguousQName Nothing qs  -- TODO? Con aspect+      A.PatternSyn qs               -> hilitePatternSynonym qs+      A.Macro q                     -> hiliteQName (Just Macro) q+      A.Lit _r l                    -> hl l+      A.QuestionMark _mi _ii        -> mempty+      A.Underscore _mi              -> mempty+      A.Dot _r e                    -> hl e                   -- TODO? Projection?+      A.App _r e es                 -> hl e <> hl es+      A.WithApp _r e es             -> hl e <> hl es+      A.Lam _r bs e                 -> hl bs <> hl e+      A.AbsurdLam _r _h             -> mempty+      A.ExtendedLam _r _di _e _q cs -> hl cs -- No hilighting of generated extended lambda name!+      A.Pi _r tel b                 -> hl tel <> hl b+      A.Generalized _qs e           -> hl e+      A.Fun _r a b                  -> hl a <> hl b+      A.Let _r bs e                 -> hl bs <> hl e+      A.ETel _tel                   -> mempty  -- Printing only construct+      A.Rec _r ass                  -> hl ass+      A.RecUpdate _r e ass          -> hl e <> hl ass+      A.ScopedExpr _ e              -> hl e+      A.Quote _r                    -> mempty+      A.QuoteTerm _r                -> mempty+      A.Unquote _r                  -> mempty+      A.Tactic _r e es              -> hl e <> hl es+      A.DontCare e                  -> hl e+    where+    hl a = hilite a++instance (Hilite a, IsProjP a) => Hilite (A.Pattern' a) where+  hilite = \case+      A.VarP x               -> hl x+      A.ConP _i qs es        -> hiliteInductiveConstructor qs <> hl es+        -- No matching on coinductive constructors, thus, can determine NameKind here.+      A.ProjP _r _o qs       -> hiliteProjection qs+      A.DefP _r qs es        -> hl qs <> hl es+      A.WildP _r             -> mempty+      A.AsP _r x p           -> hl x <> hl p+      A.DotP r e             -> case isProjP e of+                                  Nothing       -> singleOtherAspect DottedPattern r <> hl e+                                  Just (_o, qs) -> hiliteProjection qs+      A.AbsurdP _r           -> mempty+      A.LitP _r l            -> hl l+      A.PatternSynP _r qs es -> hilitePatternSynonym qs <> hl es+      A.RecP _r ps           -> hl ps+      A.EqualP _r ps         -> hl ps+      A.WithP _ p            -> hl p+      A.AnnP _r a p          -> hl p++    where+    hl a = hilite a++instance Hilite Literal where+  hilite = \case+    LitNat{}                 -> mempty+    LitWord64{}              -> mempty+    LitFloat{}               -> mempty+    LitString{}              -> mempty+    LitChar{}                -> mempty+    LitQName x               -> hilite x+    LitMeta _fileName _id    -> mempty++-- * Minor syntactic categories+---------------------------------------------------------------------------++instance Hilite A.LHS where+  hilite (A.LHS _r lhs) = hilite lhs++instance (Hilite a, IsProjP a) => Hilite (A.LHSCore' a) where+  hilite = \case+    A.LHSHead q ps       -> hilite q   <> hilite ps+    A.LHSProj q lhs ps   -> hilite lhs <> hilite q   <> hilite ps -- TODO? Projection?+    A.LHSWith lhs wps ps -> hilite lhs <> hilite wps <> hilite ps++instance Hilite A.RHS where+  hilite = \case+      A.RHS e _ce                          -> hl e+      A.AbsurdRHS                          -> mempty+      A.WithRHS _q es cs                   -> hl es  <> hl cs  -- No highlighting for with-function-name!+      A.RewriteRHS eqs strippedPats rhs wh -> hl eqs <> hl strippedPats <> hl rhs <> hl wh+    where+    hl a = hilite a++instance (HasRange n, Hilite p, Hilite e) => Hilite (RewriteEqn' x n p e) where+  hilite = \case+    Rewrite es    -> hilite $ fmap snd es+    Invert _x pes -> hilite pes++instance Hilite a => Hilite (A.Clause' a) where+  hilite (A.Clause lhs strippedPats rhs wh _catchall) =+    hilite lhs <> hilite strippedPats <> hilite rhs <> hilite wh++instance Hilite A.ProblemEq where+  hilite (A.ProblemEq p _t _dom) = hilite p++instance Hilite A.WhereDeclarations where+  hilite (A.WhereDecls m ds) = hilite m <> hilite ds++instance Hilite A.GeneralizeTelescope where+  hilite (A.GeneralizeTel _gen tel) = hilite tel++instance Hilite A.DataDefParams where+  hilite (A.DataDefParams _gen pars) = hilite pars++instance Hilite A.ModuleApplication where+  hilite = \case+    A.SectionApp tel x es    -> hilite tel <> hilite x <> hilite es+    A.RecordModuleInstance x -> hilite x++instance Hilite A.LetBinding where+  hilite = \case+      A.LetBind    _r ai x t e     -> hl ai <> hl x <> hl t <> hl e+      A.LetPatBind _r p e          -> hl p  <> hl e+      A.LetApply   mi x es _ci dir -> hl mi <> hl x <> hl es <> hl dir+      A.LetOpen    mi x dir        -> hl mi <> hl x <> hl dir+      A.LetDeclaredVariable x      -> hl x+    where+    hl x = hilite x++instance Hilite A.TypedBinding where+  hilite = \case+    A.TBind _r tac binds e -> hilite tac <> hilite binds <> hilite e+    A.TLet _r binds        -> hilite binds++instance Hilite A.LamBinding where+  hilite = \case+    A.DomainFree tac binds -> hilite tac <> hilite binds+    A.DomainFull bind      -> hilite bind++instance Hilite a => Hilite (A.Binder' a) where+  hilite (A.Binder p x) = hilite p <> hilite x++instance Hilite A.BindName where+  hilite (A.BindName x) = hiliteBound x++instance Hilite a => Hilite (FieldAssignment' a) where+  hilite (FieldAssignment x e) = hiliteField [] x Nothing <> hilite e++instance (Hilite a, HasRange n) => Hilite (Named n a) where+  hilite (Named mn e)+    =  maybe mempty (singleAspect $ Name (Just Argument) False) mn+    <> hilite e++instance Hilite a => Hilite (Arg a) where+  hilite (Arg ai e) = hilite ai <> hilite e++instance Hilite ArgInfo where+  hilite (ArgInfo _hiding modality _origin _fv _a) = hilite modality++instance Hilite Modality where+  hilite (Modality _relevance quantity _cohesion) = hilite quantity++-- | If the 'Quantity' attribute comes with a 'Range', highlight the+-- corresponding attribute as 'Symbol'.+instance Hilite Quantity where+  hilite = singleAspect Symbol++instance Hilite ModuleInfo where+  hilite (ModuleInfo _r rAsTo asName _open _impDir)+    =  singleAspect Symbol rAsTo            -- TODO: 'to' already covered by A.ImportDirective+    <> maybe mempty hiliteAsName asName+    -- <> hilite impDir                     -- Should be covered by A.ImportDirective+    where+    hiliteAsName :: C.Name -> Hiliter+    hiliteAsName n = hiliteCName [] n noRange Nothing $ nameAsp Module++instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n))+       => Hilite (ImportDirective' m n) where+  hilite (ImportDirective _r using hiding renaming _ropen) =+    hilite using <> hilite hiding <> hilite renaming++instance (Hilite m, Hilite n) => Hilite (Using' m n) where+  hilite = \case+    UseEverything -> mempty+    Using using   -> hilite using++instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n))+       => Hilite (Renaming' m n) where+  hilite (Renaming from to _fixity rangeKwTo)+    =  hilite from+    <> singleAspect Symbol rangeKwTo+         -- Currently, the "to" is already highlited by rAsTo above.+         -- TODO: remove the "to" ranges from rAsTo.+    <> hilite (RenamingTo to)++instance (Hilite m, Hilite n) => Hilite (ImportedName' m n) where+  hilite = \case+    ImportedModule m -> hilite m+    ImportedName   n -> hilite n++-- * Highlighting of names+---------------------------------------------------------------------------++instance Hilite DisambiguatedName where+  hilite (DisambiguatedName k x) = hiliteQName (Just k) x++instance Hilite ResolvedName where+  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+      where k = kindOfNameToNameKind <$> exactConName i+    PatternSynResName xs         -> hilitePatternSynonym $ A.AmbQ $ fmap anameName xs+    UnknownName                  -> mempty++instance Hilite A.QName where+  hilite = hiliteQName Nothing++instance Hilite A.AmbiguousQName where+  hilite = hiliteAmbiguousQName Nothing++instance Hilite A.ModuleName where+  hilite m@(A.MName xs) = do+    modMap <- asks hleModMap+    hiliteModule (isTopLevelModule modMap, m)+    where+    isTopLevelModule modMap =+      case mapMaybe+          ((Strict.toLazy . P.srcFile) <=< (P.rStart . A.nameBindingSite)) xs of+        f : _ ->+          Map.lookup f modMap+            == Just (C.toTopLevelModuleName $ A.mnameToConcrete m)+        [] -> False++  -- Andreas, 2020-09-29, issue #4952.+-- The target of a @renaming@ clause needs to be highlighted in a special way.+newtype RenamingTo a = RenamingTo a++instance Hilite (RenamingTo A.QName) where+  -- Andreas, 2020-09-29, issue #4952.+  -- Do not include the bindingSite, because the HTML backed turns it into garbage.+  hilite (RenamingTo q) = do+    kind <- asks hleNameKinds <&> ($ q)+    hiliteAName q False $ nameAsp' kind++instance Hilite (RenamingTo A.ModuleName) where+  -- Andreas, 2020-09-29, issue #4952.+  -- Do not include the bindingSite, because the HTML backed turns it into garbage.+  hilite (RenamingTo (A.MName ns)) = flip foldMap ns $ \ n ->+    hiliteCName [] (A.nameConcrete n) noRange Nothing $ nameAsp Module++instance (Hilite (RenamingTo m), Hilite (RenamingTo n))+       => Hilite (RenamingTo (ImportedName' m n)) where+  hilite (RenamingTo x) = case x of+    ImportedModule m -> hilite (RenamingTo m)+    ImportedName   n -> hilite (RenamingTo n)++hiliteQName+  :: Maybe NameKind   -- ^ Is 'NameKind' already known from the context?+  -> A.QName+  -> Hiliter+hiliteQName mkind q+  | isExtendedLambdaName q = mempty+  | isAbsurdLambdaName   q = mempty+  | otherwise = do+      kind <- ifJust mkind (pure . Just) {-else-} $ asks hleNameKinds <&> ($ q)+      hiliteAName q True $ nameAsp' kind++-- | Takes the first 'NameKind'.  Binding site only included if unique.+hiliteAmbiguousQName+  :: Maybe NameKind   -- ^ Is 'NameKind' already known from the context?+  -> A.AmbiguousQName+  -> Hiliter+hiliteAmbiguousQName mkind (A.AmbQ qs) = do+  kind <- ifJust mkind (pure . Just) {-else-} $ do+    kinds <- asks hleNameKinds+    pure $ listToMaybe $ List1.catMaybes $ fmap kinds qs+      -- Ulf, 2014-06-03: [issue1064] It's better to pick the first rather+      -- than doing no highlighting if there's an ambiguity between an+      -- inductive and coinductive constructor.+  flip foldMap qs $ \ q ->+    hiliteAName q include $ nameAsp' kind+  where+  include = List1.allEqual $ fmap bindingSite qs++hiliteBound :: A.Name -> Hiliter+hiliteBound x =+  hiliteCName [] (A.nameConcrete x) noRange (Just $ A.nameBindingSite x) $ nameAsp Bound++hiliteInductiveConstructor :: A.AmbiguousQName -> Hiliter+hiliteInductiveConstructor = hiliteAmbiguousQName $ Just $ Constructor Inductive++hilitePatternSynonym :: A.AmbiguousQName -> Hiliter+hilitePatternSynonym = hiliteInductiveConstructor  -- There are no coinductive pattern synonyms!?++hiliteProjection :: A.AmbiguousQName -> Hiliter+hiliteProjection = hiliteAmbiguousQName (Just Field)++hiliteField :: [C.Name] -> C.Name -> Maybe Range -> Hiliter+hiliteField xs x bindingR = hiliteCName xs x noRange bindingR $ nameAsp Field++-- For top level modules, we set the binding site to the beginning of the file+-- so that clicking on an imported module will jump to the beginning of the file+-- which defines this module.+hiliteModule :: (Bool, A.ModuleName) -> Hiliter+hiliteModule (isTopLevelModule, A.MName []) = mempty+hiliteModule (isTopLevelModule, A.MName (n:ns)) =+  hiliteCName+    (map A.nameConcrete ms)+    (A.nameConcrete m)+    noRange+    mR+    (nameAsp Module)+  where+  (ms, m) = initLast1 n ns+  mR = Just $+       applyWhen isTopLevelModule P.beginningOfFile $+       A.nameBindingSite m++-- This was Highlighting.Generate.nameToFile:+-- | Converts names to suitable 'File's.+hiliteCName+  :: [C.Name]+     -- ^ The name qualifier (may be empty).+  -> C.Name     -- ^ The base name.+  -> Range+     -- ^ The 'Range' of the name in its fixity declaration (if any).+  -> Maybe Range+     -- ^ The definition site of the name. The calculated+     --   meta information is extended with this information, if possible.+  -> (Bool -> Aspects)+     -- ^ Meta information to be associated with the name.+     --   The argument is 'True' iff the name is an operator.+  -> Hiliter+hiliteCName xs x fr mR asp = do+  HiliteEnv _ modMap fileName <- ask+  -- We don't care if we get any funny ranges.+  if all (== Strict.Just fileName) fileNames then pure $+    frFile modMap <>+    H.singleton (rToR rs)+                (aspects { definitionSite = mFilePos modMap })+   else+    mempty+  where+  aspects       = asp $ C.isOperator x+  fileNames     = mapMaybe (fmap P.srcFile . P.rStart . getRange) (x : xs)+  frFile modMap = H.singleton (rToR fr) (aspects { definitionSite = notHere <$> mFilePos modMap })+  rs            = getRange (x : xs)++  -- The fixity declaration should not get a symbolic anchor.+  notHere d = d { defSiteHere = False }++  mFilePos+    :: SourceToModule  -- Maps source file paths to module names.+    -> Maybe DefinitionSite+  mFilePos modMap = do+    r <- mR+    P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r+    mod <- Map.lookup f modMap+    -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors.+    -- We drop the file name part from the qualifiers, since+    -- this is contained in the html file name already.+    -- We want to get anchors of the form:+    -- @<a name="TopLevelModule.html#LocalModule.NestedModule.identifier">@+    let qualifiers = drop (length $ C.moduleNameParts mod) xs+    -- For bound variables, we do not create symbolic anchors.+        local = maybe True isLocalAspect $ aspect aspects+    return $ DefinitionSite+      { defSiteModule = mod+      , defSitePos    = fromIntegral p+        -- Is our current position the definition site?+      , defSiteHere   = r == getRange x+        -- For bound variables etc. we do not create a symbolic anchor name.+        -- Also not for names that include anonymous modules,+        -- otherwise, we do not get unique anchors.+      , defSiteAnchor = if local || C.isNoName x || any Common.isUnderscore qualifiers+          then Nothing+          else Just $ prettyShow $ foldr C.Qual (C.QName x) qualifiers+      }++  -- Is the name a bound variable or similar? If in doubt, yes.+  isLocalAspect :: Aspect -> Bool+  isLocalAspect = \case+    Name (Just kind) _ -> isLocal kind+    _ -> True+  isLocal :: NameKind -> Bool+  isLocal = \case+    Bound         -> True+    Generalizable -> True+    Argument      -> True+    Constructor{} -> False+    Datatype      -> False+    Field         -> False+    Function      -> False+    Module        -> False+    Postulate     -> False+    Primitive     -> False+    Record        -> False+    Macro         -> False++-- This was Highlighting.Generate.nameToFileA:+-- | A variant of 'hiliteCName' for qualified abstract names.+hiliteAName+  :: A.QName+     -- ^ The name.+  -> Bool+     -- ^ Should the binding site be included in the file?+  -> (Bool -> Aspects)+     -- ^ Meta information to be associated with the name.+     -- ^ The argument is 'True' iff the name is an operator.+  -> Hiliter+hiliteAName x include asp = do+  fileName <- asks hleFileName+  hiliteCName (concreteQualifier x)+              (concreteBase x)+              (rangeOfFixityDeclaration fileName)+              (if include then Just $ bindingSite x else Nothing)+              asp+    <> (notationFile fileName)+  where+  -- TODO: Currently we highlight fixity and syntax declarations by+  -- producing highlighting something like once per occurrence of the+  -- related name(s) in the file of the declaration (and we explicitly+  -- avoid doing this for other files). Perhaps it would be better to+  -- only produce this highlighting once.++  rangeOfFixityDeclaration fileName =+    if P.rangeFile r == Strict.Just fileName+    then r else noRange+    where+    r = theNameRange $ A.nameFixity $ A.qnameName x++  notationFile fileName = pure $+    if P.rangeFile (getRange notation) == Strict.Just fileName+    then mconcat $ map genPartFile notation+    else mempty+    where+    notation = theNotation $ A.nameFixity $ A.qnameName x++    boundAspect = nameAsp Bound False++    genPartFile (BindHole r i)   = several [rToR r, rToR $ getRange i] boundAspect+    genPartFile (NormalHole r i) = several [rToR r, rToR $ getRange i] boundAspect+    genPartFile WildHole{}       = mempty+    genPartFile (IdPart x)       = H.singleton (rToR $ getRange x) (asp False)++-- * Short auxiliary functions.+---------------------------------------------------------------------------++singleAspect :: HasRange a => Aspect -> a -> Hiliter+singleAspect a x = pure $ H.singleton (rToR $ getRange x) $ parserBased { aspect = Just a }++singleOtherAspect :: HasRange a => OtherAspect -> a -> Hiliter+singleOtherAspect a x = pure $ H.singleton (rToR $ getRange x) $ parserBased { otherAspects = singleton a }++nameAsp' :: Maybe NameKind -> Bool -> Aspects+nameAsp' k isOp = parserBased { aspect = Just $ Name k isOp }++nameAsp :: NameKind -> Bool -> Aspects+nameAsp = nameAsp' . Just++concreteBase :: A.QName -> C.Name+concreteBase = A.nameConcrete . A.qnameName++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

@@ -1,6 +1,9 @@  -- | Generates data used for precise syntax highlighting. +-- {-# OPTIONS_GHC -fwarn-unused-imports #-}  -- Semigroup import obsolete in later ghcs+-- {-# OPTIONS_GHC -fwarn-unused-binds   #-}+ module Agda.Interaction.Highlighting.Generate   ( Level(..)   , generateAndPrintSyntaxInfo@@ -12,9 +15,9 @@   , printHighlightingInfo   , highlightAsTypeChecked   , highlightWarning, warningHighlighting-  , computeUnsolvedMetaWarnings-  , computeUnsolvedConstraints-  , storeDisambiguatedName, disambiguateRecordFields+  , computeUnsolvedInfo+  , storeDisambiguatedConstructor, storeDisambiguatedProjection+  , disambiguateRecordFields   ) where  import Prelude hiding (null)@@ -22,44 +25,40 @@ import Control.Monad import Control.Arrow (second) -import Data.Generics.Geniplate+import qualified Data.Foldable as Fold import qualified Data.Map as Map import Data.Maybe import Data.List ((\\)) import qualified Data.List as List-import qualified Data.Foldable as Fold (fold, foldMap, toList) import qualified Data.IntMap as IntMap import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap+import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq) import qualified Data.Set as Set-import qualified Data.Text.Lazy as T-import Data.Void+import qualified Data.Text.Lazy as Text  import Agda.Interaction.Response-  ( Response( Resp_HighlightingInfo )-  , RemoveTokenBasedHighlighting( KeepHighlighting )-  )-import Agda.Interaction.Highlighting.Precise as P-import Agda.Interaction.Highlighting.Range (rToR, minus)  -- Range is ambiguous+  ( RemoveTokenBasedHighlighting( KeepHighlighting ) )+import Agda.Interaction.Highlighting.Precise as H+import Agda.Interaction.Highlighting.Range+  (rToR, rangeToRange, overlappings, Ranges)+import Agda.Interaction.Highlighting.FromAbstract -import qualified Agda.TypeChecking.Errors as E-import Agda.TypeChecking.MetaVars (isBlockedTerm)+import qualified Agda.TypeChecking.Errors as TCM+import Agda.TypeChecking.MetaVars (isBlockedTerm, hasTwinMeta) import Agda.TypeChecking.Monad   hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype)-import qualified Agda.TypeChecking.Monad as M+import qualified Agda.TypeChecking.Monad  as TCM+import qualified Agda.TypeChecking.Pretty as TCM import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Warnings (runPM)+import Agda.TypeChecking.Warnings ( raiseWarningsOnUsage, runPM ) -import Agda.Syntax.Abstract (IsProjP(..)) import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Concrete (FieldAssignment'(..))-import Agda.Syntax.Concrete.Definitions as W ( DeclarationWarning(..) )+import Agda.Syntax.Concrete.Definitions as W ( DeclarationWarning(..), DeclarationWarning'(..) )+import Agda.Syntax.Common (pattern Ranged) import qualified Agda.Syntax.Common as Common import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Info ( ModuleInfo(..), defMacro ) import qualified Agda.Syntax.Internal as I import qualified Agda.Syntax.Literal as L import qualified Agda.Syntax.Parser as Pa@@ -67,15 +66,18 @@ import qualified Agda.Syntax.Position as P import Agda.Syntax.Position (Range, HasRange, getRange, noRange) +import Agda.Syntax.Scope.Base     ( WithKind(..) )+import Agda.Syntax.Abstract.Views ( KName, declaredNames )+ import Agda.Utils.FileName-import Agda.Utils.Function-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List+import Agda.Utils.List            ( caseList, initWithDefault, last1 )+import Agda.Utils.List2           ( List2 )+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Null import Agda.Utils.Pretty+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -90,10 +92,16 @@     --   constructors.  -- | Highlight a warning.+--   We do not generate highlighting for unsolved metas and+--   constraints, as that gets handled in bulk after typechecking. highlightWarning :: TCWarning -> TCM () highlightWarning tcwarn = do-  let h = compress $ warningHighlighting tcwarn-  modifyTCLens stSyntaxInfo (h <>)+  let h = convert $ warningHighlighting' False tcwarn+  -- Highlighting for warnings coming from the Happy parser is placed+  -- together with token highlighting.+  case tcWarning tcwarn of+    ParseWarning{} -> modifyTCLens stTokens     (h <>)+    _              -> modifyTCLens stSyntaxInfo (h <>)   ifTopLevelAndHighlightingLevelIs NonInteractive $     printHighlightingInfo KeepHighlighting h @@ -103,282 +111,80 @@ -- highlighting info (in case of a conflict new info takes precedence -- over old info). ----- The procedure makes use of some of the token highlighting info in--- 'stTokens' (that corresponding to the interval covered by the--- declaration). If the boolean is 'True', then this token--- highlighting info is additionally removed from 'stTokens'.+-- The procedure makes use of some of the highlighting info+-- corresponding to 'stTokens' (that corresponding to the interval+-- covered by the declaration). If the boolean is 'True', then this+-- highlighting info is additionally removed from the data structure+-- that 'stTokens' refers to.  generateAndPrintSyntaxInfo   :: A.Declaration+       -- ^ Declaration to highlight.   -> Level+       -- ^ Amount of highlighting.   -> Bool-     -- ^ Update the state?+       -- ^ Update the state?   -> TCM () generateAndPrintSyntaxInfo decl _ _ | null $ getRange decl = return () generateAndPrintSyntaxInfo decl hlLevel updateState = do   file <- getCurrentPath -  reportSLn "import.iface.create" 15 $-      "Generating syntax info for " ++ filePath file ++ ' ' :-        case hlLevel of-            Full    {} -> "(final)"-            Partial {} -> "(first approximation)"-        ++ "."--  reportSLn "highlighting.names" 60 $ "highlighting names = " ++ prettyShow names+  reportSLn "import.iface.create" 15 $ concat+    [ "Generating syntax info for "+    , filePath file+    , case hlLevel of+        Full   {} -> " (final)."+        Partial{} -> " (first approximation)."+    ] -  M.ignoreAbstractMode $ do+  ignoreAbstractMode $ do     modMap <- sourceToModule     kinds  <- nameKinds hlLevel decl -    let nameInfo = mconcat $ map (generate modMap file kinds) names-     -- After the code has been type checked more information may be     -- available for overloaded constructors, and-    -- generateConstructorInfo takes advantage of this information.+    -- @generateConstructorInfo@ takes advantage of this information.     -- Note, however, that highlighting for overloaded constructors is-    -- included also in nameInfo.+    -- included also in @nameInfo@.     constructorInfo <- case hlLevel of       Full{} -> generateConstructorInfo modMap file kinds decl       _      -> return mempty -    cm <- P.rangeFile <$> viewTC eRange-    reportSLn "highlighting.warning" 60 $ "current path = " ++ show cm+    -- Main source of scope-checker generated highlighting:+    let nameInfo = runHighlighter modMap file kinds decl -    let (from, to) = case P.rangeToInterval (getRange decl) of-          Nothing -> __IMPOSSIBLE__-          Just i  -> ( fromIntegral $ P.posPos $ P.iStart i-                     , fromIntegral $ P.posPos $ P.iEnd i)-    (prevTokens, (curTokens, postTokens)) <--      second (splitAtC to) . splitAtC from <$> useTC stTokens+    reportSDoc "highlighting.warning" 60 $ TCM.hcat+      [ "current path = "+      , Strict.maybe "(nothing)" (return . pretty) =<< do+          P.rangeFile <$> viewTC eRange+      ] -    -- theRest needs to be placed before nameInfo here since record-    -- field declarations contain QNames. constructorInfo also needs-    -- to be placed before nameInfo since, when typechecking is done,+    -- Highlighting from the lexer and Happy parser:+    (curTokens, otherTokens) <-+      insideAndOutside (rangeToRange (getRange decl)) <$> useTC stTokens++    -- @constructorInfo@ needs+    -- to be placed before @nameInfo@ since, when typechecking is done,     -- constructors are included in both lists. Finally the token     -- information is placed last since token highlighting is more     -- crude than the others.-    let syntaxInfo = compress (mconcat [ constructorInfo-                                       , theRest modMap file-                                       , nameInfo-                                       ])-                       `mappend`+    let syntaxInfo = convert (constructorInfo <> nameInfo)+                       <>                      curTokens      when updateState $ do       stSyntaxInfo `modifyTCLens` mappend syntaxInfo-      stTokens     `setTCLens` (prevTokens `mappend` postTokens)+      stTokens     `setTCLens`    otherTokens      ifTopLevelAndHighlightingLevelIs NonInteractive $       printHighlightingInfo KeepHighlighting syntaxInfo-  where-  -- All names mentioned in the syntax tree (not bound variables).-  names :: [A.AmbiguousQName]-  names =-    (map I.unambiguous $-     filter (not . isExtendedLambdaName) $-     universeBi decl) ++-    universeBi decl -  -- Bound variables, dotted patterns, record fields, module names,-  -- the "as" and "to" symbols and some other things.-  theRest :: SourceToModule -> AbsolutePath -> File-  theRest modMap file = mconcat-    [ Fold.foldMap getFieldDecl   $ universeBi decl-    , Fold.foldMap getVarAndField $ universeBi decl-    , Fold.foldMap getLet         $ universeBi decl-    , Fold.foldMap getLam         $ universeBi decl-    , Fold.foldMap getTyped       $ universeBi decl-    , Fold.foldMap getPattern     $ universeBi decl-    , Fold.foldMap getPatternSyn  $ universeBi decl-    , Fold.foldMap getExpr        $ universeBi decl-    , Fold.foldMap getPatSynArgs  $ universeBi decl-    , Fold.foldMap getModuleName  $ universeBi decl-    , Fold.foldMap getModuleInfo  $ universeBi decl-    , Fold.foldMap getNamedArgE   $ universeBi decl-    , Fold.foldMap getNamedArgP   $ universeBi decl-    , Fold.foldMap getNamedArgB   $ universeBi decl-    , Fold.foldMap getNamedArgL   $ universeBi decl-    , Fold.foldMap getQuantityAttr$ universeBi decl-    , Fold.foldMap getPragma      $ universeBi decl-    ]-    where-    bound A.BindName{ unBind = n } =-      nameToFile modMap file [] (A.nameConcrete n) noRange-                 (\isOp -> parserBased { aspect =-                             Just $ Name (Just Bound) isOp })-                 (Just $ A.nameBindingSite n)--    patsyn n =               -- TODO: resolve overloading-              nameToFileA modMap file (I.headAmbQ n) True $ \isOp ->-                  parserBased { aspect =-                    Just $ Name (Just $ Constructor Common.Inductive) isOp }--    macro n = nameToFileA modMap file n True $ \isOp ->-                  parserBased { aspect = Just $ Name (Just Macro) isOp }--    field :: [C.Name] -> C.Name -> File-    field m n = nameToFile modMap file m n noRange-                           (\isOp -> parserBased { aspect =-                                       Just $ Name (Just Field) isOp })-                           Nothing--    asName :: C.Name -> File-    asName n = nameToFile modMap file []-                          n noRange-                          (\isOp -> parserBased { aspect =-                                      Just $ Name (Just Module) isOp })-                          Nothing--    -- For top level modules, we set the binding site to the beginning of the file-    -- so that clicking on an imported module will jump to the beginning of the file-    -- which defines this module.-    mod isTopLevelModule n =-      nameToFile modMap file []-                 (A.nameConcrete n) noRange-                 (\isOp -> parserBased { aspect =-                             Just $ Name (Just Module) isOp })-                 (Just $ applyWhen isTopLevelModule P.beginningOfFile $-                           A.nameBindingSite n)--    getVarAndField :: A.Expr -> File-    getVarAndField (A.Var x)            = bound $ A.mkBindName x-    -- Andreas, 2018-06-09, issue #3120-    -- The highlighting for record field tags is now created by the type checker in-    -- function disambiguateRecordFields.-    -- Andreas, Nisse, 2018-10-26, issue #3322-    -- Still, we extract the highlighting info here for uses such as QuickLatex.-    -- The aspects from the disambiguation will be merged in.-    getVarAndField (A.Rec       _ fs)   = mconcat [ field [] x | Left (FieldAssignment x _) <- fs ]-    getVarAndField (A.RecUpdate _ _ fs) = mconcat [ field [] x |      (FieldAssignment x _) <- fs ]-    getVarAndField _                    = mempty--    -- Ulf, 2019-01-30: It would be nicer to not have to specialize it, but-    -- you can't have polymorphic functions in universeBi.-    getNamedArgE :: Common.NamedArg A.Expr -> File-    getNamedArgE = getNamedArg-    getNamedArgP :: Common.NamedArg A.Pattern -> File-    getNamedArgP = getNamedArg-    getNamedArgB :: Common.NamedArg A.BindName -> File-    getNamedArgB = getNamedArg-    getNamedArgL :: Common.NamedArg A.LHSCore -> File-    getNamedArgL = getNamedArg--    getNamedArg :: Common.NamedArg a -> File-    getNamedArg x = caseMaybe (Common.nameOf $ Common.unArg x) mempty $ \ s ->-      singleton (rToR $ getRange s) $-        parserBased { aspect = Just $ Name (Just Argument) False }--    getBinder :: A.Binder -> File-    getBinder (A.Binder _ n) = bound n--    getLet :: A.LetBinding -> File-    getLet (A.LetBind _ _ x _ _)     = bound x-    getLet A.LetPatBind{}            = mempty-    getLet A.LetApply{}              = mempty-    getLet A.LetOpen{}               = mempty-    getLet (A.LetDeclaredVariable x) = bound x--    getLam :: A.LamBinding -> File-    getLam (A.DomainFree _ xs) = getBinder (Common.namedArg xs)-    getLam (A.DomainFull {})   = mempty--    getTyped :: A.TypedBinding -> File-    getTyped (A.TBind _ _ xs _) = Fold.foldMap (getBinder . Common.namedArg) xs-    getTyped A.TLet{}           = mempty--    getPatSynArgs :: A.Declaration -> File-    getPatSynArgs (A.PatternSynDef _ xs _) = mconcat $ map (bound . A.mkBindName . Common.unArg) xs-    getPatSynArgs _                        = mempty--    -- Issue #4361, highlight BUILTINs like NAT, EQUALITY etc. in keyword color.-    getPragma :: A.Declaration -> File-    getPragma = \case-      A.Pragma _ p ->-        case p of-          A.BuiltinPragma b _      -> keyword b-          A.BuiltinNoDefPragma b _ -> keyword b-          A.CompilePragma b _ _    -> keyword b-          A.RewritePragma r _      -> keyword r-          A.OptionsPragma{}   -> mempty-          A.StaticPragma{}    -> mempty-          A.EtaPragma{}       -> mempty-          A.InjectivePragma{} -> mempty-          A.InlinePragma{}    -> mempty-          A.DisplayPragma{}   -> mempty-      _ -> mempty--    keyword :: HasRange a => a -> File-    keyword x = singleton (rToR $ getRange x) $ parserBased { aspect = Just Keyword }--    getPattern' :: IsProjP e => A.Pattern' e -> File-    getPattern' (A.VarP x)    = bound x-    getPattern' (A.AsP _ x _) = bound x-    getPattern' (A.DotP pi e)-      | Just _ <- isProjP e = mempty-      | otherwise =-          singleton (rToR $ getRange pi)-                (parserBased { otherAspects = Set.singleton DottedPattern })-    getPattern' (A.PatternSynP _ q _) = patsyn q-    -- Andreas, 2018-06-09, issue #3120-    -- The highlighting for record field tags is now created by the type checker in-    -- function disambiguateRecordFields.-    -- Andreas, Nisse, 2018-10-26, issue #3322-    -- Still, we extract the highlighting info here for uses such as QuickLatex.-    -- The aspects from the disambiguation will be merged in.-    getPattern' (A.RecP _ fs) = mconcat [ field [] x | FieldAssignment x _ <- fs ]-    getPattern' _             = mempty--    getPattern :: A.Pattern -> File-    getPattern = getPattern'--    getPatternSyn :: A.Pattern' Void -> File-    getPatternSyn = getPattern'--    getExpr :: A.Expr -> File-    getExpr (A.PatternSyn q) = patsyn q-    getExpr (A.Macro q)      = macro q-    getExpr _                = mempty--    getFieldDecl :: A.Declaration -> File-    getFieldDecl (A.RecDef _ _ _ _ _ _ _ _ fs) = Fold.foldMap extractField fs-      where-      extractField (A.ScopedDecl _ ds) = Fold.foldMap extractField ds-      extractField (A.Field _ x _)     = field (concreteQualifier x)-                                               (concreteBase x)-      extractField _                   = mempty-    getFieldDecl _                   = mempty--    getModuleName :: A.ModuleName -> File-    getModuleName m@(A.MName { A.mnameToList = xs }) =-      mconcat $ map (mod isTopLevelModule) xs-      where-      isTopLevelModule =-        case mapMaybe (join .-                  fmap (Strict.toLazy . P.srcFile) .-                  P.rStart .-                  A.nameBindingSite) xs of-          f : _ -> Map.lookup f modMap ==-                   Just (C.toTopLevelModuleName $ A.mnameToConcrete m)-          []    -> False--    getModuleInfo :: ModuleInfo -> File-    getModuleInfo (ModuleInfo{ minfoAsTo, minfoAsName }) =-      singleton (rToR minfoAsTo) (parserBased { aspect = Just Symbol })-        `mappend`-      maybe mempty asName minfoAsName--    -- If the Quantity attribute comes with a Range, highlight the-    -- corresponding attribute as Symbol.-    getQuantityAttr :: Common.Quantity -> File-    getQuantityAttr q = singleton (rToR $ getRange q) (parserBased { aspect = Just Symbol })- -- | Generate and return the syntax highlighting information for the -- tokens in the given file. -generateTokenInfo :: AbsolutePath -> TCM CompressedFile+generateTokenInfo :: AbsolutePath -> TCM HighlightingInfo generateTokenInfo file =-  generateTokenInfoFromSource file . T.unpack =<<+  generateTokenInfoFromSource file . Text.unpack =<<     runPM (Pa.readFilePM file)  -- | Generate and return the syntax highlighting information for the@@ -390,15 +196,15 @@   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.-  -> TCM CompressedFile+  -> TCM HighlightingInfo generateTokenInfoFromSource file input =-  runPM $ tokenHighlighting <$> fst <$> Pa.parseFile Pa.tokensParser file input+  runPM $ tokenHighlighting . fst <$> Pa.parseFile Pa.tokensParser file input  -- | Generate and return the syntax highlighting information for the -- tokens in the given string, which is assumed to correspond to the -- given range. -generateTokenInfoFromString :: Range -> String -> TCM CompressedFile+generateTokenInfoFromString :: Range -> String -> TCM HighlightingInfo generateTokenInfoFromString r _ | r == noRange = return mempty generateTokenInfoFromString r s = do   runPM $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s@@ -406,43 +212,33 @@     Just p = P.rStart r  -- | Compute syntax highlighting for the given tokens.-tokenHighlighting :: [T.Token] -> CompressedFile-tokenHighlighting = merge . map tokenToCFile+tokenHighlighting :: [T.Token] -> HighlightingInfo+tokenHighlighting = convert . mconcat . map tokenToHI   where   -- Converts an aspect and a range to a file.-  aToF a r = singletonC (rToR r) (mempty { aspect = Just a })--  -- Merges /sorted, non-overlapping/ compressed files.-  merge = CompressedFile . concat . map ranges--  tokenToCFile :: T.Token -> CompressedFile-  tokenToCFile (T.TokSetN (i, _))               = aToF PrimitiveType (getRange i)-  tokenToCFile (T.TokPropN (i, _))              = aToF PrimitiveType (getRange i)-  tokenToCFile (T.TokKeyword T.KwSet  i)        = aToF PrimitiveType (getRange i)-  tokenToCFile (T.TokKeyword T.KwProp i)        = aToF PrimitiveType (getRange i)-  tokenToCFile (T.TokKeyword T.KwForall i)      = aToF Symbol (getRange i)-  tokenToCFile (T.TokKeyword T.KwREWRITE _)     = mempty  -- #4361, REWRITE is not always a Keyword-  tokenToCFile (T.TokKeyword _ i)               = aToF Keyword (getRange i)-  tokenToCFile (T.TokSymbol  _ i)               = aToF Symbol (getRange i)-  tokenToCFile (T.TokLiteral (L.LitNat    r _)) = aToF Number r-  tokenToCFile (T.TokLiteral (L.LitWord64 r _)) = aToF Number r-  tokenToCFile (T.TokLiteral (L.LitFloat  r _)) = aToF Number r-  tokenToCFile (T.TokLiteral (L.LitString r _)) = aToF String r-  tokenToCFile (T.TokLiteral (L.LitChar   r _)) = aToF String r-  tokenToCFile (T.TokLiteral (L.LitQName  r _)) = aToF String r-  tokenToCFile (T.TokLiteral (L.LitMeta r _ _)) = aToF String r-  tokenToCFile (T.TokComment (i, _))            = aToF Comment (getRange i)-  tokenToCFile (T.TokTeX (i, _))                = aToF Background (getRange i)-  tokenToCFile (T.TokMarkup (i, _))             = aToF Markup (getRange i)-  tokenToCFile (T.TokId {})                     = mempty-  tokenToCFile (T.TokQId {})                    = mempty-  tokenToCFile (T.TokString (i,s))              = aToF Pragma (getRange i)-  tokenToCFile (T.TokDummy {})                  = mempty-  tokenToCFile (T.TokEOF {})                    = mempty---- | A function mapping names to the kind of name they stand for.+  aToF a r = H.singleton (rToR r) (mempty { aspect = Just a }) -type NameKinds = A.QName -> Maybe NameKind+  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.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  -- | Builds a 'NameKinds' function. @@ -463,8 +259,9 @@     _      -> return empty       -- Traverses the syntax tree and constructs a map from qualified       -- names to name kinds. TODO: Handle open public.-  let syntax = foldr ($) HMap.empty $ map declToKind $ universeBi decl-  return $ \ n -> unionsMaybeWith merge+  let syntax :: NameKindMap+      syntax = runBuilder (declaredNames decl :: NameKindBuilder) HMap.empty+  return $ \ n -> unionsMaybeWith mergeNameKind     [ defnToKind . theDef <$> HMap.lookup n local     , con <$ Map.lookup n locPatSyns     , defnToKind . theDef <$> HMap.lookup n imported@@ -472,63 +269,52 @@     , 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+                            | otherwise            = Function+  defnToKind   TCM.Datatype{}                        = Datatype+  defnToKind   TCM.Record{}                          = Record+  defnToKind   TCM.Constructor{ TCM.conInd = i }       = Constructor i+  defnToKind   TCM.Primitive{}                       = Primitive+  defnToKind   TCM.PrimitiveSort{}                   = Primitive+  defnToKind   TCM.AbstractDefn{}                    = __IMPOSSIBLE__ -  -- | The 'M.Axiom' constructor is used to represent various things-  -- which are not really axioms, so when maps are merged 'Postulate's-  -- are thrown away whenever possible. The 'declToKind' function-  -- below can return several explanations for one qualified name; the-  -- 'Postulate's are bogus.-  merge Postulate k = k-  merge _     Macro = Macro  -- If the abstract syntax says macro, it's a macro.-  merge k         _ = k+  con :: NameKind+  con = Constructor Common.Inductive -  insert = HMap.insertWith merge+-- | The 'TCM.Axiom' constructor is used to represent various things+-- which are not really axioms, so when maps are merged 'Postulate's+-- are thrown away whenever possible. The 'declaredNames' function+-- below can return several explanations for one qualified name; the+-- 'Postulate's are bogus.+mergeNameKind :: NameKind -> NameKind -> NameKind+mergeNameKind Postulate k = k+mergeNameKind _     Macro = Macro  -- If the abstract syntax says macro, it's a macro.+mergeNameKind k         _ = k -  defnToKind :: Defn -> NameKind-  defnToKind   M.Axiom{}                           = Postulate-  defnToKind   M.DataOrRecSig{}                    = Postulate-  defnToKind   M.GeneralizableVar{}                = Generalizable-  defnToKind d@M.Function{} | isProperProjection d = Field-                            | otherwise            = Function-  defnToKind   M.Datatype{}                        = Datatype-  defnToKind   M.Record{}                          = Record-  defnToKind   M.Constructor{ M.conInd = i }       = Constructor i-  defnToKind   M.Primitive{}                       = Primitive-  defnToKind   M.AbstractDefn{}                    = __IMPOSSIBLE__+-- Auxiliary types for @nameKinds@ generation -  declToKind :: A.Declaration ->-                HashMap A.QName NameKind -> HashMap A.QName NameKind-  declToKind (A.Axiom _ i _ _ q _)-    | defMacro i == Common.MacroDef = insert q Macro-    | otherwise                     = insert q Postulate-  declToKind (A.Field _ q _)        = insert q Field -- Function-    -- Note that the name q can be used both as a field name and as a-    -- projection function. Highlighting of field names is taken care-    -- of by "theRest" above, which does not use NameKinds.-  declToKind (A.Primitive _ q _)    = insert q Primitive-  declToKind (A.Mutual {})          = id-  declToKind (A.Section {})         = id-  declToKind (A.Apply {})           = id-  declToKind (A.Import {})          = id-  declToKind (A.Pragma {})          = id-  declToKind (A.ScopedDecl {})      = id-  declToKind (A.Open {})            = id-  declToKind (A.PatternSynDef q _ _) = insert q con-  declToKind (A.Generalize _ _ _ q _) = insert q Generalizable-  declToKind (A.FunDef  _ q _ _)     = insert q Function-  declToKind (A.UnquoteDecl _ _ qs _) = foldr (\ q f -> insert q Function . f) id qs-  declToKind (A.UnquoteDef _ qs _)    = foldr (\ q f -> insert q Function . f) id qs-  declToKind (A.DataSig _ q _ _)      = insert q Datatype-  declToKind (A.DataDef _ q _ _ cs)   = \m ->-                                      insert q Datatype $-                                      foldr (\d -> insert (A.axiomName d) con)-                                            m cs-  declToKind (A.RecSig _ q _ _)       = insert q Record-  declToKind (A.RecDef _ q _ _ _ c _ _ _) = insert q Record . maybe id (`insert` con) c+type NameKindMap     = HashMap A.QName NameKind+data NameKindBuilder = NameKindBuilder+  { runBuilder :: NameKindMap -> NameKindMap+  } -  con :: NameKind-  con = Constructor Common.Inductive+instance Semigroup (NameKindBuilder) where+  NameKindBuilder f <> NameKindBuilder g = NameKindBuilder $ f . g +instance Monoid (NameKindBuilder) where+  mempty = NameKindBuilder id+  mappend = (<>)++instance Singleton KName NameKindBuilder where+  singleton (WithKind k q) = NameKindBuilder $+    HMap.insertWith mergeNameKind q $ kindOfNameToNameKind k++instance Collection KName NameKindBuilder+ -- | Generates syntax highlighting information for all constructors -- occurring in patterns and expressions in the given declaration. --@@ -541,16 +327,16 @@   -> AbsolutePath    -- ^ The module to highlight.   -> NameKinds   -> A.Declaration-  -> TCM File+  -> TCM HighlightingInfoBuilder generateConstructorInfo modMap file kinds decl = do    -- Get boundaries of current declaration.   -- @noRange@ should be impossible, but in case of @noRange@-  -- it makes sense to return the empty File.-  ifNull (P.rangeIntervals $ getRange decl)-         (return mempty) $ \is -> do-    let start = fromIntegral $ P.posPos $ P.iStart $ head is-        end   = fromIntegral $ P.posPos $ P.iEnd   $ last is+  -- it makes sense to return mempty.+  caseList (P.rangeIntervals $ getRange decl)+           (return mempty) $ \ i is -> do+    let start = fromIntegral $ P.posPos $ P.iStart i+        end   = fromIntegral $ P.posPos $ P.iEnd $ last1 i is      -- Get all disambiguated names that fall within the range of decl.     m0 <- useTC stDisambiguatedNames@@ -559,180 +345,233 @@         constrs = IntMap.elems m2      -- Return suitable syntax highlighting information.-    let files = for constrs $ \ q -> generate modMap file kinds $ I.unambiguous q-    return $ Fold.fold files+    return $ foldMap (runHighlighter modMap file kinds) constrs  printSyntaxInfo :: Range -> TCM () printSyntaxInfo r = do   syntaxInfo <- useTC stSyntaxInfo   ifTopLevelAndHighlightingLevelIs NonInteractive $-      printHighlightingInfo KeepHighlighting (selectC r syntaxInfo)+    printHighlightingInfo KeepHighlighting+      (restrictTo (rangeToRange r) syntaxInfo)  -- | Prints syntax highlighting info for an error.  printErrorInfo :: TCErr -> TCM () printErrorInfo e =-  printHighlightingInfo KeepHighlighting . compress =<<+  printHighlightingInfo KeepHighlighting . convert =<<     errorHighlighting e  -- | Generate highlighting for error. -errorHighlighting :: TCErr -> TCM File-errorHighlighting e = do--  -- Erase previous highlighting.-  let r     = getRange e-      erase = singleton (rToR $ P.continuousPerLine r) mempty+errorHighlighting :: TCErr -> TCM HighlightingInfoBuilder+errorHighlighting e = errorHighlighting' (getRange e) <$> TCM.prettyError e -  -- Print new highlighting.-  s <- E.prettyError e-  let error = singleton (rToR r)+errorHighlighting'+  :: Range     -- ^ Error range.+  -> String    -- ^ Error message for tooltip.+  -> HighlightingInfoBuilder+errorHighlighting' r s = mconcat+  [ -- Erase previous highlighting.+    H.singleton (rToR $ P.continuousPerLine r) mempty+  , -- Print new highlighting.+    H.singleton (rToR r)          $ parserBased { otherAspects = Set.singleton Error-                       , note         = Just s+                       , note         = s                        }-  return $ mconcat [ erase, error ]+  ] +-- | Highlighting for warnings that are considered fatal.++errorWarningHighlighting :: HasRange a => a -> HighlightingInfoBuilder+errorWarningHighlighting w =+  H.singleton (rToR $ P.continuousPerLine $ getRange w) $+    parserBased { otherAspects = Set.singleton ErrorWarning }+-- errorWarningHighlighting w = errorHighlighting' (getRange w) ""+  -- MonadPretty not available here, so, no tooltip.+  -- errorHighlighting' (getRange w) . render <$> TCM.prettyWarning (tcWarning w)+ -- | Generate syntax highlighting for warnings. -warningHighlighting :: TCWarning -> File-warningHighlighting w = case tcWarning w of+warningHighlighting :: TCWarning -> HighlightingInfoBuilder+warningHighlighting = warningHighlighting' True++warningHighlighting' :: Bool -- ^ should we generate highlighting for unsolved metas and constrains?+                     -> TCWarning -> HighlightingInfoBuilder+warningHighlighting' b w = case tcWarning w of   TerminationIssue terrs     -> terminationErrorHighlighting terrs   NotStrictlyPositive d ocs  -> positivityErrorHighlighting d ocs   -- #3965 highlight each unreachable clause independently: they   -- may be interleaved with actually reachable clauses!-  UnreachableClauses _ rs    -> Fold.foldMap deadcodeHighlighting rs+  UnreachableClauses _ rs    -> foldMap deadcodeHighlighting rs   CoverageIssue{}            -> coverageErrorHighlighting $ getRange w   CoverageNoExactSplit{}     -> catchallHighlighting $ getRange w-  UnsolvedConstraints cs     -> constraintsHighlighting cs-  UnsolvedMetaVariables rs   -> metasHighlighting rs-  AbsurdPatternRequiresNoRHS{} -> deadcodeHighlighting $ getRange w-  ModuleDoesntExport{}         -> deadcodeHighlighting $ getRange w-  FixityInRenamingModule rs    -> Fold.foldMap deadcodeHighlighting rs+  UnsolvedConstraints cs     -> if b then constraintsHighlighting [] cs else mempty+  UnsolvedMetaVariables rs   -> if b then metasHighlighting rs          else mempty+  AbsurdPatternRequiresNoRHS{} -> deadcodeHighlighting w+  ModuleDoesntExport{}         -> deadcodeHighlighting w+  DuplicateUsing xs            -> foldMap deadcodeHighlighting xs+  FixityInRenamingModule rs    -> foldMap deadcodeHighlighting rs   -- expanded catch-all case to get a warning for new constructors   CantGeneralizeOverSorts{}  -> mempty   UnsolvedInteractionMetas{} -> mempty   OldBuiltin{}               -> mempty-  EmptyRewritePragma{}       -> deadcodeHighlighting $ getRange w-  IllformedAsClause{}        -> deadcodeHighlighting $ getRange w-  UselessPublic{}            -> deadcodeHighlighting $ getRange w+  EmptyRewritePragma{}       -> deadcodeHighlighting w+  EmptyWhere{}               -> deadcodeHighlighting w+  IllformedAsClause{}        -> deadcodeHighlighting w+  UselessPublic{}            -> deadcodeHighlighting w+  UselessHiding xs           -> foldMap deadcodeHighlighting xs   UselessInline{}            -> mempty-  ClashesViaRenaming _ xs    -> Fold.foldMap (deadcodeHighlighting . getRange) xs+  UselessPatternDeclarationForRecord{} -> deadcodeHighlighting w+  ClashesViaRenaming _ xs    -> foldMap deadcodeHighlighting xs     -- #4154, TODO: clashing renamings are not dead code, but introduce problems.     -- Should we have a different color?   WrongInstanceDeclaration{} -> mempty-  InstanceWithExplicitArg{}  -> deadcodeHighlighting $ getRange w+  InstanceWithExplicitArg{}  -> deadcodeHighlighting w   InstanceNoOutputTypeName{} -> mempty   InstanceArgWithExplicitArg{} -> mempty-  ParseWarning{}             -> mempty   InversionDepthReached{}    -> mempty+  NoGuardednessFlag{}        -> mempty   GenericWarning{}           -> mempty-  GenericNonFatalError{}     -> mempty-  SafeFlagPostulate{}        -> mempty-  SafeFlagPragma{}           -> mempty-  SafeFlagNonTerminating     -> mempty-  SafeFlagTerminating        -> mempty-  SafeFlagWithoutKFlagPrimEraseEquality -> mempty-  SafeFlagEta                -> mempty-  SafeFlagInjective          -> mempty-  SafeFlagNoCoverageCheck    -> mempty+  GenericUseless r _         -> deadcodeHighlighting r+  -- Andreas, 2020-03-21, issue #4456:+  -- Error warnings that do not have dedicated highlighting+  -- are highlighted as errors.+  GenericNonFatalError{}                -> errorWarningHighlighting w+  SafeFlagPostulate{}                   -> errorWarningHighlighting w+  SafeFlagPragma{}                      -> errorWarningHighlighting w+  SafeFlagNonTerminating                -> errorWarningHighlighting w+  SafeFlagTerminating                   -> errorWarningHighlighting w+  SafeFlagWithoutKFlagPrimEraseEquality -> errorWarningHighlighting w+  SafeFlagEta                           -> errorWarningHighlighting w+  SafeFlagInjective                     -> errorWarningHighlighting w+  SafeFlagNoCoverageCheck               -> errorWarningHighlighting w+  SafeFlagNoPositivityCheck             -> errorWarningHighlighting w+  SafeFlagPolarity                      -> errorWarningHighlighting w+  SafeFlagNoUniverseCheck               -> errorWarningHighlighting w+  InfectiveImport{}                     -> errorWarningHighlighting w+  CoInfectiveImport{}                   -> errorWarningHighlighting w   WithoutKFlagPrimEraseEquality -> mempty-  SafeFlagNoPositivityCheck  -> mempty-  SafeFlagPolarity           -> mempty-  SafeFlagNoUniverseCheck    -> mempty   DeprecationWarning{}       -> mempty   UserWarning{}              -> mempty   LibraryWarning{}           -> mempty-  InfectiveImport{}          -> mempty-  CoInfectiveImport{}        -> mempty-  RewriteNonConfluent{}      -> confluenceErrorHighlighting $ getRange w-  RewriteMaybeNonConfluent{} -> confluenceErrorHighlighting $ getRange w-  PragmaCompileErased{}      -> deadcodeHighlighting $ getRange w-  NotInScopeW{}              -> deadcodeHighlighting $ getRange w-  NicifierIssue w           -> case w of+  RewriteNonConfluent{}      -> confluenceErrorHighlighting w+  RewriteMaybeNonConfluent{} -> confluenceErrorHighlighting w+  RewriteAmbiguousRules{}    -> confluenceErrorHighlighting w+  RewriteMissingRule{}       -> confluenceErrorHighlighting w+  PragmaCompileErased{}      -> deadcodeHighlighting w+  NotInScopeW{}              -> deadcodeHighlighting w+  AsPatternShadowsConstructorOrPatternSynonym{}+                             -> deadcodeHighlighting w+  RecordFieldWarning w       -> recordFieldWarningHighlighting w+  ParseWarning w             -> case w of+    Pa.UnsupportedAttribute{}     -> deadcodeHighlighting w+    Pa.MultipleAttributes{}       -> deadcodeHighlighting w+    Pa.OverlappingTokensWarning{} -> mempty+  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 $ getRange w-    EmptyAbstract{}                  -> deadcodeHighlighting $ getRange w-    EmptyInstance{}                  -> deadcodeHighlighting $ getRange w-    EmptyMacro{}                     -> deadcodeHighlighting $ getRange w-    EmptyMutual{}                    -> deadcodeHighlighting $ getRange w-    EmptyPostulate{}                 -> deadcodeHighlighting $ getRange w-    EmptyPrimitive{}                 -> deadcodeHighlighting $ getRange w-    EmptyPrivate{}                   -> deadcodeHighlighting $ getRange w-    EmptyGeneralize{}                -> deadcodeHighlighting $ getRange w-    EmptyField{}                     -> deadcodeHighlighting $ getRange w-    UselessAbstract{}                -> deadcodeHighlighting $ getRange w-    UselessInstance{}                -> deadcodeHighlighting $ getRange w-    UselessPrivate{}                 -> deadcodeHighlighting $ getRange w-    InvalidNoPositivityCheckPragma{} -> deadcodeHighlighting $ getRange w-    InvalidNoUniverseCheckPragma{}   -> deadcodeHighlighting $ getRange w-    InvalidTerminationCheckPragma{}  -> deadcodeHighlighting $ getRange w-    InvalidCoverageCheckPragma{}     -> deadcodeHighlighting $ getRange w-    OpenPublicAbstract{}             -> deadcodeHighlighting $ getRange w-    OpenPublicPrivate{}              -> deadcodeHighlighting $ getRange w-    W.ShadowingInTelescope nrs       -> Fold.foldMap+    NotAllowedInMutual{}             -> deadcodeHighlighting w+    EmptyAbstract{}                  -> deadcodeHighlighting w+    EmptyConstructor{}               -> deadcodeHighlighting w+    EmptyInstance{}                  -> deadcodeHighlighting w+    EmptyMacro{}                     -> deadcodeHighlighting w+    EmptyMutual{}                    -> deadcodeHighlighting w+    EmptyPostulate{}                 -> deadcodeHighlighting w+    EmptyPrimitive{}                 -> deadcodeHighlighting w+    EmptyPrivate{}                   -> deadcodeHighlighting w+    EmptyGeneralize{}                -> deadcodeHighlighting w+    EmptyField{}                     -> deadcodeHighlighting w+    UselessAbstract{}                -> deadcodeHighlighting w+    UselessInstance{}                -> deadcodeHighlighting w+    UselessPrivate{}                 -> deadcodeHighlighting w+    InvalidNoPositivityCheckPragma{} -> deadcodeHighlighting w+    InvalidNoUniverseCheckPragma{}   -> deadcodeHighlighting w+    InvalidTerminationCheckPragma{}  -> deadcodeHighlighting w+    InvalidCoverageCheckPragma{}     -> deadcodeHighlighting w+    InvalidConstructor{}             -> deadcodeHighlighting w+    InvalidConstructorBlock{}        -> deadcodeHighlighting w+    InvalidRecordDirective{}         -> deadcodeHighlighting w+    OpenPublicAbstract{}             -> deadcodeHighlighting w+    OpenPublicPrivate{}              -> deadcodeHighlighting w+    W.ShadowingInTelescope nrs       -> foldMap                                           (shadowingTelHighlighting . snd)                                           nrs-    MissingDefinitions{}             -> missingDefinitionHighlighting $ getRange w+    MissingDefinitions{}             -> missingDefinitionHighlighting w     -- TODO: explore highlighting opportunities here!     InvalidCatchallPragma{}           -> mempty     PolarityPragmasButNotPostulates{} -> mempty     PragmaNoTerminationCheck{}        -> mempty-    PragmaCompiled{}                  -> mempty+    PragmaCompiled{}                  -> errorWarningHighlighting w     UnknownFixityInMixfixDecl{}       -> mempty     UnknownNamesInFixityDecl{}        -> mempty     UnknownNamesInPolarityPragmas{}   -> mempty +recordFieldWarningHighlighting ::+  RecordFieldWarning -> HighlightingInfoBuilder+recordFieldWarningHighlighting = \case+  DuplicateFieldsWarning xrs      -> dead xrs+  TooManyFieldsWarning _q _ys xrs -> dead xrs+  where+  dead :: [(C.Name, Range)] -> HighlightingInfoBuilder+  dead = mconcat . map deadcodeHighlighting+  -- Andreas, 2020-03-27 #3684: This variant seems to only highlight @x@:+  -- dead = mconcat . map f+  -- f (x, r) = deadcodeHighlighting (getRange x) `mappend` deadcodeHighlighting r  -- | Generate syntax highlighting for termination errors. -terminationErrorHighlighting :: [TerminationError] -> File+terminationErrorHighlighting ::+  [TerminationError] -> HighlightingInfoBuilder terminationErrorHighlighting termErrs = functionDefs `mappend` callSites   where     m            = parserBased { otherAspects = Set.singleton TerminationProblem }-    functionDefs = Fold.foldMap (\x -> singleton (rToR $ bindingSite x) m) $-                   concatMap M.termErrFunctions termErrs-    callSites    = Fold.foldMap (\r -> singleton (rToR r) m) $-                   concatMap (map M.callInfoRange . M.termErrCalls) termErrs+    functionDefs = foldMap (\x -> H.singleton (rToR $ bindingSite x) m) $+                   concatMap termErrFunctions termErrs+    callSites    = foldMap (\r -> H.singleton (rToR r) m) $+                   concatMap (map callInfoRange . termErrCalls) termErrs+    bindingSite  = A.nameBindingSite . A.qnameName  -- | Generate syntax highlighting for not-strictly-positive inductive -- definitions. -positivityErrorHighlighting :: I.QName -> Seq OccursWhere -> File+positivityErrorHighlighting ::+  I.QName -> Seq OccursWhere -> HighlightingInfoBuilder positivityErrorHighlighting q os =   several (rToR <$> getRange q : rs) m   where     rs = map (\(OccursWhere r _ _) -> r) (Fold.toList os)     m  = parserBased { otherAspects = Set.singleton PositivityProblem } -deadcodeHighlighting :: Range -> File-deadcodeHighlighting r = singleton (rToR $ P.continuous r) m+deadcodeHighlighting :: HasRange a => a -> HighlightingInfoBuilder+deadcodeHighlighting a = H.singleton (rToR $ P.continuous $ getRange a) m   where m = parserBased { otherAspects = Set.singleton Deadcode } -coverageErrorHighlighting :: Range -> File-coverageErrorHighlighting r = singleton (rToR $ P.continuousPerLine r) m+coverageErrorHighlighting :: Range -> HighlightingInfoBuilder+coverageErrorHighlighting r = H.singleton (rToR $ P.continuousPerLine r) m   where m = parserBased { otherAspects = Set.singleton CoverageProblem } -shadowingTelHighlighting :: [Range] -> File+shadowingTelHighlighting :: List2 Range -> HighlightingInfoBuilder shadowingTelHighlighting =   -- we do not want to highlight the one variable in scope so we take   -- the @init@ segment of the ranges in question-  Fold.foldMap (\r -> singleton (rToR $ P.continuous r) m) . init+  foldMap (\r -> H.singleton (rToR $ P.continuous r) m) . List2.init   where   m = parserBased { otherAspects =-                      Set.singleton P.ShadowingInTelescope }+                      Set.singleton H.ShadowingInTelescope } -catchallHighlighting :: Range -> File-catchallHighlighting r = singleton (rToR $ P.continuousPerLine r) m+catchallHighlighting :: Range -> HighlightingInfoBuilder+catchallHighlighting r = H.singleton (rToR $ P.continuousPerLine r) m   where m = parserBased { otherAspects = Set.singleton CatchallClause } -confluenceErrorHighlighting :: Range -> File-confluenceErrorHighlighting r = singleton (rToR $ P.continuousPerLine r) m+confluenceErrorHighlighting ::+  HasRange a => a -> HighlightingInfoBuilder+confluenceErrorHighlighting a = H.singleton (rToR $ P.continuousPerLine $ getRange a) m   where m = parserBased { otherAspects = Set.singleton ConfluenceProblem } -missingDefinitionHighlighting :: Range -> File-missingDefinitionHighlighting r = singleton (rToR $ P.continuousPerLine r) m+missingDefinitionHighlighting ::+  HasRange a => a -> HighlightingInfoBuilder+missingDefinitionHighlighting a = H.singleton (rToR $ P.continuousPerLine $ getRange a) m   where m = parserBased { otherAspects = Set.singleton MissingDefinition }  -- | Generates and prints syntax highlighting information for unsolved@@ -740,232 +579,93 @@  printUnsolvedInfo :: TCM () printUnsolvedInfo = do-  metaInfo       <- computeUnsolvedMetaWarnings-  constraintInfo <- computeUnsolvedConstraints+  info <- computeUnsolvedInfo -  printHighlightingInfo KeepHighlighting-    (compress $ metaInfo `mappend` constraintInfo)+  printHighlightingInfo KeepHighlighting (convert info) +computeUnsolvedInfo :: TCM HighlightingInfoBuilder+computeUnsolvedInfo = do+  (rs, metaInfo) <- computeUnsolvedMetaWarnings+  constraintInfo <- computeUnsolvedConstraints rs++  return $ metaInfo `mappend` constraintInfo+ -- | Generates syntax highlighting information for unsolved meta -- variables.--computeUnsolvedMetaWarnings :: TCM File+--   Also returns ranges of unsolved or interaction metas.+computeUnsolvedMetaWarnings :: TCM ([Ranges], HighlightingInfoBuilder) computeUnsolvedMetaWarnings = do   is <- getInteractionMetas    -- We don't want to highlight blocked terms, since   --   * there is always at least one proper meta responsible for the blocking   --   * in many cases the blocked term covers the highlighting for this meta+  --   * for the same reason we skip metas with a twin, since the twin will be blocked.   let notBlocked m = not <$> isBlockedTerm m-  ms <- filterM notBlocked =<< getOpenMetas+  let notHasTwin m = not <$> hasTwinMeta m+  ms <- filterM notHasTwin =<< filterM notBlocked =<< getOpenMetas -  rs <- mapM getMetaRange (ms \\ is)-  return $ metasHighlighting rs+  let extend = map (rToR . P.continuousPerLine) -metasHighlighting :: [Range] -> File-metasHighlighting rs = several (map (rToR . P.continuousPerLine) rs)+  rs <- extend <$> mapM getMetaRange (ms \\ is)++  rs' <- extend <$> mapM getMetaRange is+  return $ (rs ++ rs', metasHighlighting' rs)++metasHighlighting :: [Range] -> HighlightingInfoBuilder+metasHighlighting rs = metasHighlighting' (map (rToR . P.continuousPerLine) rs)++metasHighlighting' :: [Ranges] -> HighlightingInfoBuilder+metasHighlighting' rs = several rs                      $ parserBased { otherAspects = Set.singleton UnsolvedMeta }  -- | Generates syntax highlighting information for unsolved constraints --   (ideally: that are not connected to a meta variable). -computeUnsolvedConstraints :: TCM File-computeUnsolvedConstraints = constraintsHighlighting <$> getAllConstraints+computeUnsolvedConstraints :: [Ranges] -- ^ does not add ranges that would overlap with these.+                           -> TCM HighlightingInfoBuilder+computeUnsolvedConstraints ms = constraintsHighlighting ms <$> getAllConstraints -constraintsHighlighting :: Constraints -> File-constraintsHighlighting cs =-  several (map (rToR . P.continuousPerLine) rs)+constraintsHighlighting ::+  [Ranges] -> Constraints -> HighlightingInfoBuilder+constraintsHighlighting ms cs =+  several (filter noOverlap $ map (rToR . P.continuousPerLine) rs)           (parserBased { otherAspects = Set.singleton UnsolvedConstraint })   where+  noOverlap r = not $ any (overlappings $ r) $ ms   -- 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 = TelCmp{}   } -> 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)     _ -> Nothing --- | Generates a suitable file for a possibly ambiguous name. -generate :: SourceToModule-            -- ^ Maps source file paths to module names.-         -> AbsolutePath-            -- ^ The module to highlight.-         -> NameKinds-         -> A.AmbiguousQName-         -> File-generate modMap file kinds (A.AmbQ qs) =-  Fold.foldMap (\ q -> nameToFileA modMap file q include m) qs-  where-    ks   = map kinds (Fold.toList qs)-    -- Ulf, 2014-06-03: [issue1064] It's better to pick the first rather-    -- than doing no highlighting if there's an ambiguity between an-    -- inductive and coinductive constructor.-    kind = case [ k | Just k <- ks ] of-             k : _ -> Just k-             []    -> Nothing-    -- kind = case (allEqual ks, ks) of-    --          (True, Just k : _) -> Just k-    --          _                  -> Nothing-    -- Note that all names in an AmbiguousQName should have the same-    -- concrete name, so either they are all operators, or none of-    -- them are.-    m isOp  = parserBased { aspect = Just $ Name kind isOp }-    include = allEqual (map bindingSite $ Fold.toList qs)---- | Converts names to suitable 'File's.--nameToFile :: SourceToModule-              -- ^ Maps source file paths to module names.-           -> AbsolutePath-              -- ^ The file name of the current module. Used for-              -- consistency checking.-           -> [C.Name]-              -- ^ The name qualifier (may be empty).-           -> C.Name-              -- ^ The base name.-           -> Range-              -- ^ The 'Range' of the name in its fixity declaration (if any).-           -> (Bool -> Aspects)-              -- ^ Meta information to be associated with the name.-              -- The argument is 'True' iff the name is an operator.-           -> Maybe Range-              -- ^ The definition site of the name. The calculated-              -- meta information is extended with this information,-              -- if possible.-           -> File-nameToFile modMap file xs x fr m mR =-  -- We don't care if we get any funny ranges.-  if all (== Strict.Just file) fileNames then-    frFile `mappend`-    several (map rToR rs)-            (aspects { definitionSite = mFilePos })-   else-    mempty-  where-  aspects    = m $ C.isOperator x-  fileNames  = mapMaybe (fmap P.srcFile . P.rStart . getRange) (x : xs)-  frFile     = singleton (rToR fr) (aspects { definitionSite = notHere <$> mFilePos })-  rs         = map getRange (x : xs)--  -- The fixity declaration should not get a symbolic anchor.-  notHere d = d { defSiteHere = False }--  mFilePos  :: Maybe DefinitionSite-  mFilePos   = do-    r <- mR-    P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r-    mod <- Map.lookup f modMap-    -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors.-    -- We drop the file name part from the qualifiers, since-    -- this is contained in the html file name already.-    -- We want to get anchors of the form:-    -- @<a name="TopLevelModule.html#LocalModule.NestedModule.identifier">@-    let qualifiers = drop (length $ C.moduleNameParts mod) xs-    -- For bound variables, we do not create symbolic anchors.-        local = maybe True isLocalAspect $ aspect aspects-    return $ DefinitionSite-      { defSiteModule = mod-      , defSitePos    = fromIntegral p-        -- Is our current position the definition site?-      , defSiteHere   = r == getRange x-        -- For bound variables etc. we do not create a symbolic anchor name.-        -- Also not for names that include anonymous modules,-        -- otherwise, we do not get unique anchors.-      , defSiteAnchor = if local || C.isNoName x || any Common.isUnderscore qualifiers-          then Nothing-          else Just $ prettyShow $ foldr C.Qual (C.QName x) qualifiers-      }--  -- Is the name a bound variable or similar? If in doubt, yes.-  isLocalAspect :: Aspect -> Bool-  isLocalAspect = \case-    Name mkind _ -> maybe True isLocal mkind-    _ -> True-  isLocal :: NameKind -> Bool-  isLocal = \case-    Bound         -> True-    Generalizable -> True-    Argument      -> True-    Constructor{} -> False-    Datatype      -> False-    Field         -> False-    Function      -> False-    Module        -> False-    Postulate     -> False-    Primitive     -> False-    Record        -> False-    Macro         -> False---- | A variant of 'nameToFile' for qualified abstract names.--nameToFileA-  :: SourceToModule-     -- ^ Maps source file paths to module names.-  -> AbsolutePath-     -- ^ The file name of the current module. Used for-     -- consistency checking.-  -> A.QName-     -- ^ The name.-  -> Bool-     -- ^ Should the binding site be included in the file?-  -> (Bool -> Aspects)-     -- ^ Meta information to be associated with the name.-     -- ^ The argument is 'True' iff the name is an operator.-  -> File-nameToFileA modMap file x include m =-  nameToFile modMap-             file-             (concreteQualifier x)-             (concreteBase x)-             rangeOfFixityDeclaration-             m-             (if include then Just $ bindingSite x else Nothing)-    `mappend` notationFile-  where-  -- TODO: Currently we highlight fixity and syntax declarations by-  -- producing highlighting something like once per occurrence of the-  -- related name(s) in the file of the declaration (and we explicitly-  -- avoid doing this for other files). Perhaps it would be better to-  -- only produce this highlighting once.--  rangeOfFixityDeclaration =-    if P.rangeFile r == Strict.Just file-    then r else noRange-    where-    r = Common.theNameRange $ A.nameFixity $ A.qnameName x--  notationFile =-    if P.rangeFile (getRange notation) == Strict.Just file-    then mconcat $ map genPartFile notation-    else mempty-    where-    notation = Common.theNotation $ A.nameFixity $ A.qnameName x--    boundAspect = parserBased{ aspect = Just $ Name (Just Bound) False }+-- * Disambiguation of constructors and projections. -    genPartFile (Common.BindHole r i)   = several [rToR r, rToR $ getRange i] boundAspect-    genPartFile (Common.NormalHole r i) = several [rToR r, rToR $ getRange i] boundAspect-    genPartFile Common.WildHole{}       = mempty-    genPartFile (Common.IdPart x)       = singleton (rToR $ getRange x) (m False)+storeDisambiguatedField :: A.QName -> TCM ()+storeDisambiguatedField = storeDisambiguatedName Field -concreteBase :: I.QName -> C.Name-concreteBase = A.nameConcrete . A.qnameName+storeDisambiguatedProjection :: A.QName -> TCM ()+storeDisambiguatedProjection = storeDisambiguatedField -concreteQualifier :: I.QName -> [C.Name]-concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule+storeDisambiguatedConstructor :: Common.Induction -> A.QName -> TCM ()+storeDisambiguatedConstructor i = storeDisambiguatedName $ Constructor i -bindingSite :: I.QName -> Range-bindingSite = A.nameBindingSite . A.qnameName+-- TODO: move the following function to a new module TypeChecking.Overloading+-- that gathers functions concerning disambiguation of overloading.  -- | Remember a name disambiguation (during type checking). --   To be used later during syntax highlighting.-storeDisambiguatedName :: A.QName -> TCM ()-storeDisambiguatedName q = whenJust (start $ getRange q) $ \ i ->-  stDisambiguatedNames `modifyTCLens` IntMap.insert i q+--   Also: raise user warnings associated with the name.+storeDisambiguatedName :: NameKind -> A.QName -> TCM ()+storeDisambiguatedName k q = do+  raiseWarningsOnUsage q+  whenJust (start $ getRange q) $ \ i ->+    modifyTCLens stDisambiguatedNames $ IntMap.insert i $ DisambiguatedName k q   where   start r = fromIntegral . P.posPos <$> P.rStart' r @@ -976,4 +676,4 @@   -> TCM () disambiguateRecordFields cxs axs = forM_ cxs $ \ cx -> do   caseMaybe (List.find ((cx ==) . A.nameConcrete . A.qnameName) axs) (return ()) $ \ ax -> do-    storeDisambiguatedName ax { A.qnameName = (A.qnameName ax) { A.nameConcrete = cx } }+    storeDisambiguatedField ax{ A.qnameName = (A.qnameName ax) { A.nameConcrete = cx } }

src/full/Agda/Interaction/Highlighting/HTML.hs view

@@ -1,373 +1,10 @@ --- | Function for generating highlighted, hyperlinked HTML from Agda--- sources.+-- | Backend for generating highlighted, hyperlinked HTML from Agda sources.  module Agda.Interaction.Highlighting.HTML-  ( generateHTML-  -- Reused by PandocAgda-  , defaultCSSFile-  , generateHTMLWithPageGen-  , generatePage-  , page-  , tokenStream-  , code+  ( htmlBackend   ) where -import Prelude hiding ((!!), concatMap)-import Control.Monad-import Control.Monad.Trans--import Data.Function-import Data.Foldable (toList, concatMap)-import Data.Maybe-import qualified Data.IntMap as IntMap-import qualified Data.Map    as Map-import qualified Data.List   as List-import Data.List.Split (splitWhen, chunksOf)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T--import qualified Network.URI.Encode--import System.FilePath-import System.Directory--import Text.Blaze.Html5 hiding (code, map, title)-import qualified Text.Blaze.Html5 as Html5-import Text.Blaze.Html5.Attributes as Attr-import Text.Blaze.Html.Renderer.Text-  -- The imported operator (!) attaches an Attribute to an Html value-  -- The defined operator (!!) attaches a list of such Attributes--import Paths_Agda--import Agda.Interaction.Options-import Agda.Interaction.Highlighting.Precise--import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Common--import Agda.TypeChecking.Monad (TCM, useTC)-import qualified Agda.TypeChecking.Monad as TCM--import Agda.Utils.FileName (filePath)-import Agda.Utils.Function-import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.Pretty--import Agda.Utils.Impossible---- | The name of the default CSS file.--defaultCSSFile :: FilePath-defaultCSSFile = "Agda.css"---- | The directive inserted before the rendered code blocks--rstDelimiter :: String-rstDelimiter = ".. raw:: html\n"---- | Determine how to highlight the file--highlightOnlyCode :: HtmlHighlight -> FileType -> Bool-highlightOnlyCode HighlightAll  _ = False-highlightOnlyCode HighlightCode _ = True-highlightOnlyCode HighlightAuto AgdaFileType = False-highlightOnlyCode HighlightAuto MdFileType   = True-highlightOnlyCode HighlightAuto RstFileType  = True-highlightOnlyCode HighlightAuto OrgFileType  = True-highlightOnlyCode HighlightAuto TexFileType  = False---- | Determine the generated file extension--highlightedFileExt :: HtmlHighlight -> FileType -> String-highlightedFileExt hh ft-  | not $ highlightOnlyCode hh ft = "html"-  | otherwise = case ft of-      AgdaFileType -> "html"-      MdFileType   -> "md"-      RstFileType  -> "rst"-      TexFileType  -> "tex"-      OrgFileType  -> "org"---- | Generates HTML files from all the sources which have been---   visited during the type checking phase.------   This function should only be called after type checking has---   completed successfully.--type PageGen = FilePath    -- ^ Output directory-  -> FileType              -- ^ Source file type-  -> Bool                  -- ^ Return value of `highlightOnlyCode`-  -> String                -- ^ Output file extension (return-                           --   value of `highlightedFileExt`)-  -> C.TopLevelModuleName-  -> Text-  -> CompressedFile        -- ^ Highlighting information-  -> TCM ()--generateHTML :: TCM ()-generateHTML = generateHTMLWithPageGen pageGen-  where-  pageGen :: PageGen-  pageGen dir ft pc ext mod contents hinfo =-    generatePage (renderer pc ft) ext dir mod-    where-    renderer :: Bool -> FileType -> FilePath -> FilePath -> Text-    renderer onlyCode fileType css _ =-      page css onlyCode mod $-      code onlyCode fileType $-      tokenStream contents hinfo---- | Prepare information for HTML page generation.------   The page generator receives the output directory as well as the---   module's top level module name, its source code, and its---   highlighting information.--generateHTMLWithPageGen-  :: PageGen-     -- ^ Page generator.-  -> TCM ()-generateHTMLWithPageGen generatePage = do-      options <- TCM.commandLineOptions--      -- There is a default directory given by 'defaultHTMLDir'-      let dir = optHTMLDir options-      let htmlHighlight = optHTMLHighlight options-      liftIO $ createDirectoryIfMissing True dir--      -- If the default CSS file should be used, then it is copied to-      -- the output directory.-      liftIO $ when (isNothing $ optCSSFile options) $ do-        cssFile <- getDataFileName defaultCSSFile-        copyFile cssFile (dir </> defaultCSSFile)--      TCM.reportS "html" 1-        [ "" :: String-        , "Warning: HTML is currently generated for ALL files which can be"-        , "reached from the given module, including library files."-        ]--      -- Pull source code and highlighting info from the state and-      -- generate all the web pages.-      mapM_ (\(n, mi) ->-              let i  = TCM.miInterface mi-                  ft = TCM.iFileType i in-              generatePage dir ft-                (highlightOnlyCode htmlHighlight ft)-                (highlightedFileExt htmlHighlight ft) n-                (TCM.iSource i) (TCM.iHighlighting i)) .-        Map.toList =<< TCM.getVisitedModules---- | Converts module names to the corresponding HTML file names.--modToFile :: C.TopLevelModuleName -> String -> FilePath-modToFile m ext =-  Network.URI.Encode.encode $-    render (pretty m) <.> ext---- | Generates a highlighted, hyperlinked version of the given module.--generatePage-  :: (FilePath -> FilePath -> Text)  -- ^ Page renderer.-  -> String                          -- ^ Output file extension.-  -> FilePath                        -- ^ Directory in which to create-                                     --   files.-  -> C.TopLevelModuleName            -- ^ Module to be highlighted.-  -> TCM ()-generatePage renderPage ext dir mod = do-  f   <- fromMaybe __IMPOSSIBLE__ . Map.lookup mod <$> useTC TCM.stModuleToSource-  css <- fromMaybe defaultCSSFile . optCSSFile <$> TCM.commandLineOptions-  let target = dir </> modToFile mod ext-  let html = renderPage css $ filePath f-  TCM.reportSLn "html" 1 $ "Generating HTML for " ++-                           render (pretty mod) ++-                           " (" ++ target ++ ")."-  liftIO $ UTF8.writeTextToFile target html----- | Attach multiple Attributes--(!!) :: Html -> [Attribute] -> Html-h !! as = h ! mconcat as---- | Constructs the web page, including headers.--page :: FilePath              -- ^ URL to the CSS file.-     -> Bool                  -- ^ Whether to reserve literate-     -> C.TopLevelModuleName  -- ^ Module to be highlighted.-     -> Html-     -> Text-page css htmlHighlight modName pageContent =-  renderHtml $ if htmlHighlight-               then pageContent-               else docTypeHtml $ hdr <> rest-  where--    hdr = Html5.head $ mconcat-      [ meta !! [ charset "utf-8" ]-      , Html5.title (toHtml $ render $ pretty modName)-      , link !! [ rel "stylesheet"-                , href $ stringValue css-                ]-      ]--    rest = body $ (pre ! class_ "Agda") pageContent---- | Position, Contents, Infomation--type TokenInfo =-  ( Int-  , String-  , Aspects+import Agda.Interaction.Highlighting.HTML.Backend as Exports+  ( htmlBackend   )---- | Constructs token stream ready to print.--tokenStream-     :: Text           -- ^ The contents of the module.-     -> CompressedFile -- ^ Highlighting information.-     -> [TokenInfo]-tokenStream contents info =-  map (\cs -> case cs of-          (mi, (pos, _)) : _ ->-            (pos, map (snd . snd) cs, fromMaybe mempty mi)-          [] -> __IMPOSSIBLE__) $-  List.groupBy ((==) `on` fst) $-  map (\(pos, c) -> (IntMap.lookup pos infoMap, (pos, c))) $-  zip [1..] (T.unpack contents)-  where-  infoMap = toMap (decompress info)---- | Constructs the HTML displaying the code.--code :: Bool     -- ^ Whether to generate non-code contents as-is-     -> FileType -- ^ Source file type-     -> [TokenInfo]-     -> Html-code onlyCode fileType = mconcat . if onlyCode-  then case fileType of-         -- Explicitly written all cases, so people-         -- get compile error when adding new file types-         -- when they forget to modify the code here-         RstFileType  -> map mkRst . splitByMarkup-         MdFileType   -> map mkMd . chunksOf 2 . splitByMarkup-         AgdaFileType -> map mkHtml-         -- Any points for using this option?-         TexFileType  -> map mkMd . chunksOf 2 . splitByMarkup-         OrgFileType  -> map mkOrg . splitByMarkup-  else map mkHtml-  where-  trd (_, _, a) = a--  splitByMarkup :: [TokenInfo] -> [[TokenInfo]]-  splitByMarkup = splitWhen $ (== Just Markup) . aspect . trd--  mkHtml :: TokenInfo -> Html-  mkHtml (pos, s, mi) =-    -- Andreas, 2017-06-16, issue #2605:-    -- Do not create anchors for whitespace.-    applyUnless (mi == mempty) (annotate pos mi) $ toHtml s--  -- | Proposed in #3373, implemented in #3384-  mkRst :: [TokenInfo] -> Html-  mkRst = mconcat . (toHtml rstDelimiter :) . map go-    where-      go token@(_, s, mi) = if aspect mi == Just Background-        then preEscapedToHtml s-        else mkHtml token--  -- | Proposed in #3137, implemented in #3313-  --   Improvement proposed in #3366, implemented in #3367-  mkMd :: [[TokenInfo]] -> Html-  mkMd = mconcat . go-    where-      work token@(_, s, mi) = case aspect mi of-        Just Background -> preEscapedToHtml s-        Just Markup     -> __IMPOSSIBLE__-        _               -> mkHtml token-      go [a, b] = [ mconcat $ work <$> a-                  , pre ! class_ "Agda" $ mconcat $ work <$> b-                  ]-      go [a]    = work <$> a-      go _      = __IMPOSSIBLE__--  mkOrg :: [TokenInfo] -> Html-  mkOrg = mconcat . map go-    where-      go token@(_, s, mi) = if aspect mi == Just Background-        then preEscapedToHtml s-        else mkHtml token--  -- | Put anchors that enable referencing that token.-  --   We put a fail safe numeric anchor (file position) for internal references-  --   (issue #2756), as well as a heuristic name anchor for external references-  --   (issue #2604).-  annotate :: Int -> Aspects -> Html -> Html-  annotate pos mi = applyWhen hereAnchor-      (anchorage nameAttributes mempty <>) . anchorage posAttributes-    where-    -- | Warp an anchor (<A> tag) with the given attributes around some HTML.-    anchorage :: [Attribute] -> Html -> Html-    anchorage attrs html = a html !! attrs--    -- | File position anchor (unique, reliable).-    posAttributes :: [Attribute]-    posAttributes = concat-      [ [Attr.id $ stringValue $ show pos ]-      , toList $ fmap link $ definitionSite mi-      , class_ (stringValue $ unwords classes) <$ guard (not $ null classes)-      ]--    -- | Named anchor (not reliable, but useful in the general case for outside refs).-    nameAttributes :: [Attribute]-    nameAttributes = [ Attr.id $ stringValue $ fromMaybe __IMPOSSIBLE__ $ mDefSiteAnchor ]--    classes = concat-      [ concatMap noteClasses (note mi)-      , otherAspectClasses (toList $ otherAspects mi)-      , concatMap aspectClasses (aspect mi)-      ]--    aspectClasses (Name mKind op) = kindClass ++ opClass-      where-      kindClass = toList $ fmap showKind mKind--      showKind (Constructor Inductive)   = "InductiveConstructor"-      showKind (Constructor CoInductive) = "CoinductiveConstructor"-      showKind k                         = show k--      opClass = if op then ["Operator"] else []-    aspectClasses a = [show a]---    otherAspectClasses = map show--    -- Notes are not included.-    noteClasses s = []--    -- | Should we output a named anchor?-    --   Only if we are at the definition site now (@here@)-    --   and such a pretty named anchor exists (see 'defSiteAnchor').-    hereAnchor      :: Bool-    hereAnchor      = here && isJust mDefSiteAnchor--    mDefinitionSite :: Maybe DefinitionSite-    mDefinitionSite = definitionSite mi--    -- | Are we at the definition site now?-    here            :: Bool-    here            = maybe False defSiteHere mDefinitionSite--    mDefSiteAnchor  :: Maybe String-    mDefSiteAnchor  = maybe __IMPOSSIBLE__ defSiteAnchor mDefinitionSite--    link (DefinitionSite m pos _here _aName) = href $ stringValue $-      -- If the definition site points to the top of a file,-      -- we drop the anchor part and just link to the file.-      applyUnless (pos <= 1)-        (++ "#" ++-         Network.URI.Encode.encode (show pos))-         -- Network.URI.Encode.encode (fromMaybe (show pos) aName)) -- Named links disabled-        (Network.URI.Encode.encode $ modToFile m "html")

+ src/full/Agda/Interaction/Highlighting/HTML/Backend.hs view

@@ -0,0 +1,201 @@++-- | Backend for generating highlighted, hyperlinked HTML from Agda sources.++module Agda.Interaction.Highlighting.HTML.Backend+  ( htmlBackend+  ) where++import Agda.Interaction.Highlighting.HTML.Base++import Prelude hiding ((!!), concatMap)++import Control.DeepSeq+import Control.Monad.Trans ( MonadIO )+import Control.Monad.Except ( MonadError(throwError) )++import Data.Map (Map)++import GHC.Generics (Generic)++import Agda.Interaction.Options+    ( ArgDescr(ReqArg, NoArg)+    , OptDescr(..)+    , Flag+    )+import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..))+import Agda.Compiler.Common (IsMain(..), curIF)++import Agda.Syntax.Abstract (ModuleName, toTopLevelModuleName)++import Agda.TypeChecking.Monad+  ( MonadDebug+  , ReadTCState+  , Definition+  , reportS+  )++-- | Options for HTML generation++data HtmlFlags = HtmlFlags+  { htmlFlagEnabled              :: Bool+  , htmlFlagDir                  :: FilePath+  , htmlFlagHighlight            :: HtmlHighlight+  , htmlFlagHighlightOccurrences :: Bool+  , htmlFlagCssFile              :: Maybe FilePath+  } deriving (Eq, Generic)++instance NFData HtmlFlags++data HtmlCompileEnv = HtmlCompileEnv+  { htmlCompileEnvOpts :: HtmlOptions+  }++data HtmlModuleEnv = HtmlModuleEnv+  { htmlModEnvCompileEnv :: HtmlCompileEnv+  , htmlModEnvName       :: ModuleName+  }++data HtmlModule = HtmlModule+data HtmlDef = HtmlDef++htmlBackend :: Backend+htmlBackend = Backend htmlBackend'++htmlBackend' :: Backend' HtmlFlags HtmlCompileEnv HtmlModuleEnv HtmlModule HtmlDef+htmlBackend' = Backend'+  { backendName           = "HTML"+  , backendVersion        = Nothing+  , options               = initialHtmlFlags+  , commandLineFlags      = htmlFlags+  , isEnabled             = htmlFlagEnabled+  , preCompile            = preCompileHtml+  , preModule             = preModuleHtml+  , compileDef            = compileDefHtml+  , postModule            = postModuleHtml+  , postCompile           = postCompileHtml+  -- --only-scope-checking works, but with the caveat that cross-module links+  -- will not have their definition site populated.+  , scopeCheckingSuffices = True+  , mayEraseType          = const $ return False+  }++initialHtmlFlags :: HtmlFlags+initialHtmlFlags = HtmlFlags+  { htmlFlagEnabled   = False+  , htmlFlagDir       = defaultHTMLDir+  , htmlFlagHighlight = HighlightAll+  -- Don't enable by default because it causes potential+  -- performance problems+  , htmlFlagHighlightOccurrences = False+  , htmlFlagCssFile              = Nothing+  }++htmlOptsOfFlags :: HtmlFlags -> HtmlOptions+htmlOptsOfFlags flags = HtmlOptions+  { htmlOptDir = htmlFlagDir flags+  , htmlOptHighlight = htmlFlagHighlight flags+  , htmlOptHighlightOccurrences = htmlFlagHighlightOccurrences flags+  , htmlOptCssFile = htmlFlagCssFile flags+  }++-- | The default output directory for HTML.++defaultHTMLDir :: FilePath+defaultHTMLDir = "html"++htmlFlags :: [OptDescr (Flag HtmlFlags)]+htmlFlags =+    [ Option []     ["html"] (NoArg htmlFlag)+                    "generate HTML files with highlighted source code"+    , Option []     ["html-dir"] (ReqArg htmlDirFlag "DIR")+                    ("directory in which HTML files are placed (default: " +++                     defaultHTMLDir ++ ")")+    , Option []     ["highlight-occurrences"] (NoArg highlightOccurrencesFlag)+                    ("highlight all occurrences of hovered symbol in generated " +++                     "HTML files")+    , Option []     ["css"] (ReqArg cssFlag "URL")+                    "the CSS file used by the HTML files (can be relative)"+    , Option []     ["html-highlight"] (ReqArg htmlHighlightFlag "[code,all,auto]")+                    ("whether to highlight only the code parts (code) or " +++                     "the file as a whole (all) or " +++                     "decide by source file type (auto)")+    ]++htmlFlag :: Flag HtmlFlags+htmlFlag o = return $ o { htmlFlagEnabled = True }++htmlDirFlag :: FilePath -> Flag HtmlFlags+htmlDirFlag d o = return $ o { htmlFlagDir = d }++cssFlag :: FilePath -> Flag HtmlFlags+cssFlag f o = return $ o { htmlFlagCssFile = Just f }++highlightOccurrencesFlag :: Flag HtmlFlags+highlightOccurrencesFlag o = return $ o { htmlFlagHighlightOccurrences = True }++parseHtmlHighlightFlag :: MonadError String m => String -> m HtmlHighlight+parseHtmlHighlightFlag "code" = return HighlightCode+parseHtmlHighlightFlag "all"  = return HighlightAll+parseHtmlHighlightFlag "auto" = return HighlightAuto+parseHtmlHighlightFlag opt    = throwError $ concat ["Invalid option <", opt, ">, expected <all>, <auto> or <code>"]++htmlHighlightFlag :: String -> Flag HtmlFlags+htmlHighlightFlag opt    o = do+  flag <- parseHtmlHighlightFlag opt+  return $ o { htmlFlagHighlight = flag }++runLogHtmlWithMonadDebug :: MonadDebug m => LogHtmlT m a -> m a+runLogHtmlWithMonadDebug = runLogHtmlWith $ reportS "html" 1++preCompileHtml+  :: (MonadIO m, MonadDebug m)+  => HtmlFlags+  -> m HtmlCompileEnv+preCompileHtml flags = runLogHtmlWithMonadDebug $ do+  logHtml $ unlines+    [ "Warning: HTML is currently generated for ALL files which can be"+    , "reached from the given module, including library files."+    ]+  let opts = htmlOptsOfFlags flags+  prepareCommonDestinationAssets opts+  return $ HtmlCompileEnv opts++preModuleHtml+  :: Applicative m+  => HtmlCompileEnv+  -> IsMain+  -> ModuleName+  -> Maybe FilePath+  -> m (Recompile HtmlModuleEnv HtmlModule)+preModuleHtml cenv _isMain modName _ifacePath = pure $ Recompile (HtmlModuleEnv cenv modName)++compileDefHtml+  :: Applicative m+  => HtmlCompileEnv+  -> HtmlModuleEnv+  -> IsMain+  -> Definition+  -> m HtmlDef+compileDefHtml _env _menv _isMain _def = pure HtmlDef++postModuleHtml+  :: (MonadIO m, MonadDebug m, ReadTCState m)+  => HtmlCompileEnv+  -> HtmlModuleEnv+  -> IsMain+  -> ModuleName+  -> [HtmlDef]+  -> m HtmlModule+postModuleHtml _env menv _isMain _modName _defs = do+  let generatePage = defaultPageGen . htmlCompileEnvOpts . htmlModEnvCompileEnv $ menv+  htmlSrc <- srcFileOfInterface (toTopLevelModuleName . htmlModEnvName $ menv) <$> curIF+  runLogHtmlWithMonadDebug $ generatePage htmlSrc+  return HtmlModule++postCompileHtml+  :: Applicative m+  => HtmlCompileEnv+  -> IsMain+  -> Map ModuleName HtmlModule+  -> m ()+postCompileHtml _cenv _isMain _modulesByName = pure ()

+ src/full/Agda/Interaction/Highlighting/HTML/Base.hs view

@@ -0,0 +1,424 @@++-- | Function for generating highlighted, hyperlinked HTML from Agda+-- sources.++module Agda.Interaction.Highlighting.HTML.Base+  ( HtmlOptions(..)+  , HtmlHighlight(..)+  , prepareCommonDestinationAssets+  , srcFileOfInterface+  , defaultPageGen+  , MonadLogHtml(logHtml)+  , LogHtmlT+  , runLogHtmlWith+  ) where++import Prelude hiding ((!!), concatMap)++import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans ( MonadIO(..), lift )+import Control.Monad.Trans.Reader ( ReaderT(runReaderT), ask )++import Data.Function ( on )+import Data.Foldable (toList, concatMap)+import Data.Maybe+import qualified Data.IntMap as IntMap+import qualified Data.List   as List+import Data.List.Split (splitWhen, chunksOf)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T++import GHC.Generics (Generic)++import qualified Network.URI.Encode++import System.FilePath+import System.Directory++import Text.Blaze.Html5+    ( preEscapedToHtml+    , toHtml+    , stringValue+    , Html+    , (!)+    , Attribute+    )+import qualified Text.Blaze.Html5 as Html5+import qualified Text.Blaze.Html5.Attributes as Attr+import Text.Blaze.Html.Renderer.Text ( renderHtml )+  -- The imported operator (!) attaches an Attribute to an Html value+  -- The defined operator (!!) attaches a list of such Attributes++import Paths_Agda++import Agda.Interaction.Highlighting.Precise hiding (toList)++import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Common++import qualified Agda.TypeChecking.Monad as TCM+  ( Interface(..)+  )++import Agda.Utils.Function+import qualified Agda.Utils.IO.UTF8 as UTF8+import Agda.Utils.Pretty++import Agda.Utils.Impossible++-- | The name of the default CSS file.++defaultCSSFile :: FilePath+defaultCSSFile = "Agda.css"++-- | The name of the occurrence-highlighting JS file.++occurrenceHighlightJsFile :: FilePath+occurrenceHighlightJsFile = "highlight-hover.js"++-- | The directive inserted before the rendered code blocks++rstDelimiter :: String+rstDelimiter = ".. raw:: html\n"++-- | The directive inserted before rendered code blocks in org++orgDelimiterStart :: String+orgDelimiterStart = "#+BEGIN_EXPORT html\n<pre class=\"Agda\">\n"++-- | The directive inserted after rendered code blocks in org++orgDelimiterEnd :: String+orgDelimiterEnd = "</pre>\n#+END_EXPORT\n"++-- | Determine how to highlight the file++data HtmlHighlight = HighlightAll | HighlightCode | HighlightAuto+  deriving (Show, Eq, Generic)++instance NFData HtmlHighlight++highlightOnlyCode :: HtmlHighlight -> FileType -> Bool+highlightOnlyCode HighlightAll  _ = False+highlightOnlyCode HighlightCode _ = True+highlightOnlyCode HighlightAuto AgdaFileType = False+highlightOnlyCode HighlightAuto MdFileType   = True+highlightOnlyCode HighlightAuto RstFileType  = True+highlightOnlyCode HighlightAuto OrgFileType  = True+highlightOnlyCode HighlightAuto TexFileType  = False++-- | Determine the generated file extension++highlightedFileExt :: HtmlHighlight -> FileType -> String+highlightedFileExt hh ft+  | not $ highlightOnlyCode hh ft = "html"+  | otherwise = case ft of+      AgdaFileType -> "html"+      MdFileType   -> "md"+      RstFileType  -> "rst"+      TexFileType  -> "tex"+      OrgFileType  -> "org"++-- | Options for HTML generation++data HtmlOptions = HtmlOptions+  { htmlOptDir                  :: FilePath+  , htmlOptHighlight            :: HtmlHighlight+  , htmlOptHighlightOccurrences :: Bool+  , htmlOptCssFile              :: Maybe FilePath+  } deriving Eq++-- | Internal type bundling the information related to a module source file++data HtmlInputSourceFile = HtmlInputSourceFile+  { _srcFileModuleName :: C.TopLevelModuleName+  , _srcFileType :: FileType+  -- ^ Source file type+  , _srcFileText :: Text+  -- ^ Source text+  , _srcFileHighlightInfo :: HighlightingInfo+  -- ^ Highlighting info+  }++-- | Bundle up the highlighting info for a source file++srcFileOfInterface :: C.TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile+srcFileOfInterface m i = HtmlInputSourceFile m (TCM.iFileType i) (TCM.iSource i) (TCM.iHighlighting i)++-- | Logging during HTML generation++type HtmlLogMessage = String+type HtmlLogAction m = HtmlLogMessage -> m ()++class MonadLogHtml m where+  logHtml :: HtmlLogAction m++type LogHtmlT m = ReaderT (HtmlLogAction m) m++instance Monad m => MonadLogHtml (LogHtmlT m) where+  logHtml message = do+    doLog <- ask+    lift $ doLog message++runLogHtmlWith :: Monad m => HtmlLogAction m -> LogHtmlT m a -> m a+runLogHtmlWith = flip runReaderT++renderSourceFile :: HtmlOptions -> HtmlInputSourceFile -> Text+renderSourceFile opts = renderSourcePage+  where+  cssFile = fromMaybe defaultCSSFile (htmlOptCssFile opts)+  highlightOccur = htmlOptHighlightOccurrences opts+  htmlHighlight = htmlOptHighlight opts+  renderSourcePage (HtmlInputSourceFile moduleName fileType sourceCode hinfo) =+    page cssFile highlightOccur onlyCode moduleName pageContents+    where+      tokens = tokenStream sourceCode hinfo+      onlyCode = highlightOnlyCode htmlHighlight fileType+      pageContents = code onlyCode fileType tokens++defaultPageGen :: (MonadIO m, MonadLogHtml m) => HtmlOptions -> HtmlInputSourceFile -> m ()+defaultPageGen opts srcFile@(HtmlInputSourceFile moduleName ft _ _) = do+  logHtml $ render $ "Generating HTML for"  <+> pretty moduleName <+> ((parens (pretty target)) <> ".")+  writeRenderedHtml html target+  where+    ext = highlightedFileExt (htmlOptHighlight opts) ft+    target = (htmlOptDir opts) </> modToFile moduleName ext+    html = renderSourceFile opts srcFile++prepareCommonDestinationAssets :: MonadIO m => HtmlOptions -> m ()+prepareCommonDestinationAssets options = liftIO $ do+  -- There is a default directory given by 'defaultHTMLDir'+  let htmlDir = htmlOptDir options+  createDirectoryIfMissing True htmlDir++  -- If the default CSS file should be used, then it is copied to+  -- the output directory.+  let cssFile = htmlOptCssFile options+  when (isNothing $ cssFile) $ do+    defCssFile <- getDataFileName defaultCSSFile+    copyFile defCssFile (htmlDir </> defaultCSSFile)++  let highlightOccurrences = htmlOptHighlightOccurrences options+  when highlightOccurrences $ do+    highlightJsFile <- getDataFileName $+      "JS" </> occurrenceHighlightJsFile+    copyFile highlightJsFile (htmlDir </> occurrenceHighlightJsFile)++-- | Converts module names to the corresponding HTML file names.++modToFile :: C.TopLevelModuleName -> String -> FilePath+modToFile m ext = Network.URI.Encode.encode $ render (pretty m) <.> ext++-- | Generates a highlighted, hyperlinked version of the given module.++writeRenderedHtml+  :: MonadIO m+  => Text       -- ^ Rendered page+  -> FilePath   -- ^ Output path.+  -> m ()+writeRenderedHtml html target = liftIO $ UTF8.writeTextToFile target html+++-- | Attach multiple Attributes++(!!) :: Html -> [Attribute] -> Html+h !! as = h ! mconcat as++-- | Constructs the web page, including headers.++page :: FilePath              -- ^ URL to the CSS file.+     -> Bool                  -- ^ Highlight occurrences+     -> Bool                  -- ^ Whether to reserve literate+     -> C.TopLevelModuleName  -- ^ Module to be highlighted.+     -> Html+     -> Text+page css+     highlightOccurrences+     htmlHighlight+     modName+     pageContent =+  renderHtml $ if htmlHighlight+               then pageContent+               else Html5.docTypeHtml $ hdr <> rest+  where++    hdr = Html5.head $ mconcat+      [ Html5.meta !! [ Attr.charset "utf-8" ]+      , Html5.title (toHtml . render $ pretty modName)+      , Html5.link !! [ Attr.rel "stylesheet"+                      , Attr.href $ stringValue css+                      ]+      , if highlightOccurrences+        then Html5.script mempty !!+          [ Attr.type_ "text/javascript"+          , Attr.src $ stringValue occurrenceHighlightJsFile+          ]+        else mempty+      ]++    rest = Html5.body $ (Html5.pre ! Attr.class_ "Agda") pageContent++-- | Position, Contents, Infomation++type TokenInfo =+  ( Int+  , String+  , Aspects+  )++-- | Constructs token stream ready to print.++tokenStream+     :: Text             -- ^ The contents of the module.+     -> HighlightingInfo -- ^ Highlighting information.+     -> [TokenInfo]+tokenStream contents info =+  map (\cs -> case cs of+          (mi, (pos, _)) : _ ->+            (pos, map (snd . snd) cs, fromMaybe mempty mi)+          [] -> __IMPOSSIBLE__) $+  List.groupBy ((==) `on` fst) $+  zipWith (\pos c -> (IntMap.lookup pos infoMap, (pos, c))) [1..] (T.unpack contents)+  where+  infoMap = toMap info++-- | Constructs the HTML displaying the code.++code :: Bool     -- ^ Whether to generate non-code contents as-is+     -> FileType -- ^ Source file type+     -> [TokenInfo]+     -> Html+code onlyCode fileType = mconcat . if onlyCode+  then case fileType of+         -- Explicitly written all cases, so people+         -- get compile error when adding new file types+         -- when they forget to modify the code here+         RstFileType  -> map mkRst . splitByMarkup+         MdFileType   -> map mkMd . chunksOf 2 . splitByMarkup+         AgdaFileType -> map mkHtml+         -- Any points for using this option?+         TexFileType  -> map mkMd . chunksOf 2 . splitByMarkup+         OrgFileType  -> map mkOrg . splitByMarkup+  else map mkHtml+  where+  trd (_, _, a) = a++  splitByMarkup :: [TokenInfo] -> [[TokenInfo]]+  splitByMarkup = splitWhen $ (== Just Markup) . aspect . trd++  mkHtml :: TokenInfo -> Html+  mkHtml (pos, s, mi) =+    -- Andreas, 2017-06-16, issue #2605:+    -- Do not create anchors for whitespace.+    applyUnless (mi == mempty) (annotate pos mi) $ toHtml s++  -- Proposed in #3373, implemented in #3384+  mkRst :: [TokenInfo] -> Html+  mkRst = mconcat . (toHtml rstDelimiter :) . map go+    where+      go token@(_, s, mi) = if aspect mi == Just Background+        then preEscapedToHtml s+        else mkHtml token++  -- Proposed in #3137, implemented in #3313+  -- Improvement proposed in #3366, implemented in #3367+  mkMd :: [[TokenInfo]] -> Html+  mkMd = mconcat . go+    where+      work token@(_, s, mi) = case aspect mi of+        Just Background -> preEscapedToHtml s+        Just Markup     -> __IMPOSSIBLE__+        _               -> mkHtml token+      go [a, b] = [ mconcat $ work <$> a+                  , Html5.pre ! Attr.class_ "Agda" $ mconcat $ work <$> b+                  ]+      go [a]    = work <$> a+      go _      = __IMPOSSIBLE__++  mkOrg :: [TokenInfo] -> Html+  mkOrg tokens = mconcat $ if containsCode then formatCode else formatNonCode+    where+      containsCode = any ((/= Just Background) . aspect . trd) tokens++      startDelimiter = preEscapedToHtml orgDelimiterStart+      endDelimiter = preEscapedToHtml orgDelimiterEnd++      formatCode = startDelimiter : foldr (\x -> (go x :)) [endDelimiter] tokens+      formatNonCode = map go tokens++      go token@(_, s, mi) = if aspect mi == Just Background+        then preEscapedToHtml s+        else mkHtml token++  -- Put anchors that enable referencing that token.+  -- We put a fail safe numeric anchor (file position) for internal references+  -- (issue #2756), as well as a heuristic name anchor for external references+  -- (issue #2604).+  annotate :: Int -> Aspects -> Html -> Html+  annotate pos mi =+    applyWhen hereAnchor (anchorage nameAttributes mempty <>) . anchorage posAttributes+    where+    -- Warp an anchor (<A> tag) with the given attributes around some HTML.+    anchorage :: [Attribute] -> Html -> Html+    anchorage attrs html = Html5.a html !! attrs++    -- File position anchor (unique, reliable).+    posAttributes :: [Attribute]+    posAttributes = concat+      [ [Attr.id $ stringValue $ show pos ]+      , toList $ link <$> definitionSite mi+      , Attr.class_ (stringValue $ unwords classes) <$ guard (not $ null classes)+      ]++    -- Named anchor (not reliable, but useful in the general case for outside refs).+    nameAttributes :: [Attribute]+    nameAttributes = [ Attr.id $ stringValue $ fromMaybe __IMPOSSIBLE__ $ mDefSiteAnchor ]++    classes = concat+      [ concatMap noteClasses (note mi)+      , otherAspectClasses (toList $ otherAspects mi)+      , concatMap aspectClasses (aspect mi)+      ]++    aspectClasses (Name mKind op) = kindClass ++ opClass+      where+      kindClass = toList $ fmap showKind mKind++      showKind (Constructor Inductive)   = "InductiveConstructor"+      showKind (Constructor CoInductive) = "CoinductiveConstructor"+      showKind k                         = show k++      opClass = ["Operator" | op]+    aspectClasses a = [show a]+++    otherAspectClasses = map show++    -- Notes are not included.+    noteClasses _s = []++    -- Should we output a named anchor?+    -- Only if we are at the definition site now (@here@)+    -- and such a pretty named anchor exists (see 'defSiteAnchor').+    hereAnchor      :: Bool+    hereAnchor      = here && isJust mDefSiteAnchor++    mDefinitionSite :: Maybe DefinitionSite+    mDefinitionSite = definitionSite mi++    -- Are we at the definition site now?+    here            :: Bool+    here            = maybe False defSiteHere mDefinitionSite++    mDefSiteAnchor  :: Maybe String+    mDefSiteAnchor  = maybe __IMPOSSIBLE__ defSiteAnchor mDefinitionSite++    link (DefinitionSite m defPos _here _aName) = Attr.href $ stringValue $+      -- If the definition site points to the top of a file,+      -- we drop the anchor part and just link to the file.+      applyUnless (defPos <= 1)+        (++ "#" +++         Network.URI.Encode.encode (show defPos))+         -- Network.URI.Encode.encode (fromMaybe (show defPos) aName)) -- Named links disabled+        (Network.URI.Encode.encode $ modToFile m "html")

src/full/Agda/Interaction/Highlighting/JSON.hs view

@@ -59,7 +59,7 @@       [ "remove" .= case remove of           RemoveHighlighting -> True           KeepHighlighting -> False-      , "payload" .= map (showAspects modFile) (ranges info)+      , "payload" .= map (showAspects modFile) (toList info)       ]      direct :: IO Value

src/full/Agda/Interaction/Highlighting/LaTeX.hs view

@@ -1,757 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}---- | Function for generating highlighted and aligned LaTeX from literate--- Agda source.+-- | Generating highlighted and aligned LaTeX from literate Agda source.  module Agda.Interaction.Highlighting.LaTeX-  ( generateLaTeX+  ( module Exports   ) where -import Prelude hiding (log)-import Data.Char-import Data.Maybe-import Data.Function-import Data.Foldable (toList)-import Control.Monad.RWS.Strict-import Control.Arrow (second)-import System.Directory-import System.Exit-import System.FilePath-import System.Process-import Data.Text (Text)-import qualified Data.Text               as T-#ifdef COUNT_CLUSTERS-import qualified Data.Text.ICU           as ICU-#endif-import qualified Data.Text.IO            as T-import qualified Data.Text.Lazy          as L-import qualified Data.Text.Lazy.Encoding as E-import qualified Data.ByteString.Lazy    as BS--import Data.HashSet (HashSet)-import qualified Data.HashSet as Set-import qualified Data.IntMap  as IntMap-import qualified Data.List    as List--import Paths_Agda--import Agda.Syntax.Abstract (toTopLevelModuleName)-import Agda.Syntax.Common-import Agda.Syntax.Concrete-  (TopLevelModuleName, moduleNameParts, projectRoot)-import Agda.Syntax.Parser.Literate (literateTeX, LayerRole, atomizeLayers)-import qualified Agda.Syntax.Parser.Literate as L-import Agda.Syntax.Position (startPos)-import qualified Agda.Interaction.FindFile as Find-import Agda.Interaction.Highlighting.Precise-import Agda.TypeChecking.Monad (TCM, Interface(..))-import qualified Agda.TypeChecking.Monad as TCM-import qualified Agda.Interaction.Options as O-import Agda.Utils.FileName (filePath, AbsolutePath, mkAbsolute)--import Agda.Utils.Impossible----------------------------------------------------------------------------- * Datatypes.---- | The @LaTeX@ monad is a combination of @ExceptT@, @RWST@ and--- @IO@. The error part is just used to keep track whether we finished--- or not, the reader part isn't used, the writer is where the output--- goes and the state is for keeping track of the tokens and some other--- useful info, and the I/O part is used for printing debugging info.--type LaTeX = RWST () [Output] State IO---- | Output items.--data Output-  = Text !Text-    -- ^ A piece of text.-  | MaybeColumn !AlignmentColumn-    -- ^ A column. If it turns out to be an indentation column that is-    --   not used to indent or align something, then no column will be-    --   generated, only whitespace ('agdaSpace').-  deriving Show---- | Column kinds.--data Kind-  = Indentation-    -- ^ Used only for indentation (the placement of the first token-    -- on a line, relative to tokens on previous lines).-  | Alignment-    -- ^ Used both for indentation and for alignment.-  deriving (Eq, Show)---- | Unique identifiers for indentation columns.--type IndentationColumnId = Int---- | Alignment and indentation columns.--data AlignmentColumn = AlignmentColumn-  { columnCodeBlock :: !Int-    -- ^ The column's code block.-  , columnColumn :: !Int-    -- ^ The column number.-  , columnKind :: Maybe IndentationColumnId-    -- ^ The column kind. 'Nothing' for alignment columns and @'Just'-    -- i@ for indentation columns, where @i@ is the column's unique-    -- identifier.-  } deriving Show--data State = State-  { codeBlock     :: !Int   -- ^ The number of the current code block.-  , column        :: !Int   -- ^ The current column number.-  , columns       :: [AlignmentColumn]-                            -- ^ All alignment columns found on the-                            --   current line (so far), in reverse-                            --   order.-  , columnsPrev   :: [AlignmentColumn]-                            -- ^ All alignment columns found in-                            --   previous lines (in any code block),-                            --   with larger columns coming first.-  , nextId        :: !IndentationColumnId-                            -- ^ The next indentation column-                            -- identifier.-  , usedColumns   :: HashSet IndentationColumnId-                            -- ^ Indentation columns that have-                            -- actually-                            --   been used.-  , countClusters :: !Bool  -- ^ Count extended grapheme clusters?-  }--type Tokens = [Token]--data Token = Token-  { text     :: !Text-  , info     :: Aspects-  }-  deriving Show--withTokenText :: (Text -> Text) -> Token -> Token-withTokenText f tok@Token{text = t} = tok{text = f t}--data Debug = MoveColumn | NonCode | Code | Spaces | Output-  deriving (Eq, Show)---- | Says what debug information should printed.--debugs :: [Debug]-debugs = []---- | Run function for the @LaTeX@ monad.-runLaTeX ::-  LaTeX a -> () -> State -> IO (a, State, [Output])-runLaTeX = runRWST--emptyState-  :: Bool  -- ^ Count extended grapheme clusters?-  -> State-emptyState cc = State-  { codeBlock     = 0-  , column        = 0-  , columns       = []-  , columnsPrev   = []-  , nextId        = 0-  , usedColumns   = Set.empty-  , countClusters = cc-  }----------------------------------------------------------------------------- * Some helpers.---- | Gives the size of the string. If cluster counting is enabled,--- then the number of extended grapheme clusters is computed (the root--- locale is used), and otherwise the number of code points.--size :: Text -> LaTeX Int-size t = do-  cc <- countClusters <$> get-  if cc then-#ifdef COUNT_CLUSTERS-    return $ length $ ICU.breaks (ICU.breakCharacter ICU.Root) t-#else-    __IMPOSSIBLE__-#endif-   else-    return $ T.length t--(<+>) :: Text -> Text -> Text-(<+>) = T.append---- | Does the string consist solely of whitespace?--isSpaces :: Text -> Bool-isSpaces = T.all isSpace---- | Is the character a whitespace character distinct from '\n'?--isSpaceNotNewline :: Char -> Bool-isSpaceNotNewline c = isSpace c && c /= '\n'---- | Replaces all forms of whitespace, except for new-line characters,--- with spaces.--replaceSpaces :: Text -> Text-replaceSpaces = T.map (\c -> if isSpaceNotNewline c then ' ' else c)----- | If the `Token` consists of spaces, the internal column counter is advanced---   by the length of the token. Otherwise, `moveColumnForToken` is a no-op.-moveColumnForToken :: Token -> LaTeX ()-moveColumnForToken t = do-  unless (isSpaces (text t)) $ do-    log MoveColumn $ text t-    moveColumn =<< size (text t)---- | Merges 'columns' into 'columnsPrev', resets 'column' and--- 'columns'--resetColumn :: LaTeX ()-resetColumn = modify $ \s ->-  s { column      = 0-    , columnsPrev = merge (columns s) (columnsPrev s)-    , columns     = []-    }-  where-  -- Remove shadowed columns from old.-  merge []  old = old-  merge new old = new ++ filter ((< leastNew) . columnColumn) old-    where-    leastNew = columnColumn (last new)--moveColumn :: Int -> LaTeX ()-moveColumn i = modify $ \s -> s { column = i + column s }---- | Registers a column of the given kind. The column is returned.--registerColumn :: Kind -> LaTeX AlignmentColumn-registerColumn kind = do-  column    <- gets column-  codeBlock <- gets codeBlock-  kind      <- case kind of-                 Alignment   -> return Nothing-                 Indentation -> do-                   nextId <- gets nextId-                   modify $ \s -> s { nextId = succ nextId }-                   return (Just nextId)-  let c = AlignmentColumn { columnColumn    = column-                          , columnCodeBlock = codeBlock-                          , columnKind      = kind-                          }-  modify $ \s -> s { columns = c : columns s }-  return c---- | Registers the given column as used (if it is an indentation--- column).--useColumn :: AlignmentColumn -> LaTeX ()-useColumn c = case columnKind c of-  Nothing -> return ()-  Just i  -> modify $ \s ->-               s { usedColumns = Set.insert i (usedColumns s) }---- | Alignment column zero in the current code block.--columnZero :: LaTeX AlignmentColumn-columnZero = do-  codeBlock <- gets codeBlock-  return $ AlignmentColumn { columnColumn    = 0-                           , columnCodeBlock = codeBlock-                           , columnKind      = Nothing-                           }---- | Registers column zero as an alignment column.--registerColumnZero :: LaTeX ()-registerColumnZero = do-  c <- columnZero-  modify $ \s -> s { columns = [c] }---- | Changes to the state that are performed at the start of a code--- block.--enterCode :: LaTeX ()-enterCode = do-  resetColumn-  modify $ \s -> s { codeBlock = codeBlock s + 1 }---- | Changes to the state that are performed at the end of a code--- block.--leaveCode :: LaTeX ()-leaveCode = return ()--logHelper :: Debug -> Text -> [String] -> LaTeX ()-logHelper debug text extra =-  when (debug `elem` debugs) $ do-    lift $ T.putStrLn $ T.pack (show debug ++ ": ") <+>-      "'" <+> text <+> "' " <+>-      if null extra-         then T.empty-         else "(" <+> T.pack (unwords extra) <+> ")"--log :: Debug -> Text -> LaTeX ()-log MoveColumn text = do-  cols <- gets columns-  logHelper MoveColumn text ["columns=", show cols]-log Code text = do-  cols <- gets columns-  col <- gets column-  logHelper Code text ["columns=", show cols, "col=", show col]-log debug text = logHelper debug text []--log' :: Debug -> String -> LaTeX ()-log' d = log d . T.pack--output :: Output -> LaTeX ()-output item = do-  log' Output (show item)-  tell [item]----------------------------------------------------------------------------- * LaTeX and polytable strings.---- Polytable, http://www.ctan.org/pkg/polytable, is used for code--- alignment, similar to lhs2TeX's approach.--nl :: Text-nl = "%\n"---- | A command that is used when two tokens are put next to each other--- in the same column.--agdaSpace :: Text-agdaSpace = cmdPrefix <+> "Space" <+> cmdArg T.empty <+> nl---- | The column's name.------ Indentation columns have unique names, distinct from all alignment--- column names.--columnName :: AlignmentColumn -> Text-columnName c = T.pack $ case columnKind c of-  Nothing -> show (columnColumn c)-  Just i  -> show i ++ "I"---- | Opens a column with the given name.--ptOpen' :: Text -> Text-ptOpen' name = "\\>[" <+> name <+> "]"---- | Opens the given column.--ptOpen :: AlignmentColumn -> Text-ptOpen c = ptOpen' (columnName c)---- | Opens a special column that is only used at the beginning of--- lines.--ptOpenBeginningOfLine :: Text-ptOpenBeginningOfLine = ptOpen' "." <+> "[@{}l@{}]"---- | Opens the given column, and inserts an indentation instruction--- with the given argument at the end of it.--ptOpenIndent-  :: AlignmentColumn-  -> Int              -- ^ Indentation instruction argument.-  -> Text-ptOpenIndent c delta =-  ptOpen c <+> "[@{}l@{"-           <+> cmdPrefix-           <+> "Indent"-           <+> cmdArg (T.pack $ show delta)-           <+> "}]"--ptClose :: Text-ptClose = "\\<"--ptClose' :: AlignmentColumn -> Text-ptClose' c =-  ptClose <+> "[" <+> columnName c <+> "]"--ptNL :: Text-ptNL = nl <+> "\\\\\n"--ptEmptyLine :: Text-ptEmptyLine =-  nl <+> "\\\\["-     <+> cmdPrefix-     <+> "EmptyExtraSkip"-     <+> "]%\n"--cmdPrefix :: Text-cmdPrefix = "\\Agda"--cmdArg :: Text -> Text-cmdArg x = "{" <+> x <+> "}"----------------------------------------------------------------------------- * Output generation from a stream of labelled tokens.--processLayers :: [(LayerRole, Tokens)] -> LaTeX ()-processLayers = mapM_ $ \(layerRole,toks) -> do-  case layerRole of-    L.Markup  -> processMarkup  toks-    L.Comment -> processComment toks-    L.Code    -> processCode    toks--processMarkup, processComment, processCode :: Tokens -> LaTeX ()---- | Deals with markup, which is output verbatim.-processMarkup = mapM_ $ \t -> do-  moveColumnForToken t-  output (Text (text t))---- | Deals with literate text, which is output verbatim-processComment = mapM_ $ \t -> do-  unless ("%" == T.take 1 (T.stripStart (text t))) $ do-    moveColumnForToken t-  output (Text (text t))---- | Deals with code blocks. Every token, except spaces, is pretty--- printed as a LaTeX command.-processCode toks' = do-  output $ Text nl-  enterCode-  mapM_ go toks'-  ptOpenWhenColumnZero =<< gets column-  output $ Text $ ptClose <+> nl-  leaveCode--  where-    go tok' = do-      -- Get the column information before grabbing the token, since-      -- grabbing (possibly) moves the column.-      col  <- gets column--      moveColumnForToken tok'-      let tok = text tok'-      log Code tok--      if (tok == T.empty) then return ()-      else do-        if (isSpaces tok) then do-            spaces $ T.group $ replaceSpaces tok-        else do-          ptOpenWhenColumnZero col-          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)-                  (escape tok)-                  $ map fromOtherAspect (toList $ otherAspects $ info tok') ++-                    concatMap fromAspect (toList $ aspect $ info tok')--    -- Non-whitespace tokens at the start of a line trigger an-    -- alignment column.-    ptOpenWhenColumnZero col =-        when (col == 0) $ do-          registerColumnZero-          output . Text . ptOpen =<< columnZero--    -- 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--    fromAspect :: Aspect -> [String]-    fromAspect a = let s = [show a] in case a of-      Comment           -> s-      Keyword           -> s-      String            -> s-      Number            -> s-      Symbol            -> s-      PrimitiveType     -> s-      Pragma            -> s-      Background        -> s-      Markup            -> s-      Name Nothing isOp -> fromAspect (Name (Just Postulate) isOp)-        -- At the time of writing the case above can be encountered in-        -- --only-scope-checking mode, for instance for the token "Size"-        -- in the following code:-        ---        --   {-# BUILTIN SIZE Size #-}-        ---        -- 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-          Bound                     -> s-          Generalizable             -> s-          Constructor Inductive     -> "InductiveConstructor"-          Constructor CoInductive   -> "CoinductiveConstructor"-          Datatype                  -> s-          Field                     -> s-          Function                  -> s-          Module                    -> s-          Postulate                 -> s-          Primitive                 -> s-          Record                    -> s-          Argument                  -> s-          Macro                     -> s-        where-        s = show kind---- | Escapes special characters.-escape :: Text -> Text-escape (T.uncons -> Nothing)     = T.empty-escape (T.uncons -> Just (c, s)) = T.pack (replace c) <+> escape s-  where-  replace :: Char -> String-  replace c = case c of-    '_'  -> "\\AgdaUnderscore{}"-    '{'  -> "\\{"-    '}'  -> "\\}"-    '#'  -> "\\#"-    '$'  -> "\\$"-    '&'  -> "\\&"-    '%'  -> "\\%"-    '~'  -> "\\textasciitilde{}"-    '^'  -> "\\textasciicircum{}"-    '\\' -> "\\textbackslash{}"-    _    -> [ c ]-#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--- list elements must not contain the same character.------ If the final element of the list consists of spaces, then these--- spaces are assumed to not be trailing whitespace.-spaces :: [Text] -> LaTeX ()-spaces [] = return ()---- Newlines.-spaces (s@(T.uncons -> Just ('\n', _)) : ss) = do-  col <- gets column-  when (col == 0) $-    output . Text . ptOpen =<< columnZero-  output $ Text $ ptClose <+> ptNL <+>-                  T.replicate (T.length s - 1) ptEmptyLine-  resetColumn-  spaces ss---- Spaces followed by a newline character.-spaces (_ : ss@(_ : _)) = spaces ss---- Spaces that are not followed by a newline character.-spaces [ s ] = do-  col <- gets column--  let len  = T.length s-      kind = if col /= 0 && len == 1-             then Indentation-             else Alignment--  moveColumn len-  column <- registerColumn kind--  if col /= 0-  then log' Spaces "col /= 0"-  else do-    columns    <- gets columnsPrev-    codeBlock  <- gets codeBlock--    log' Spaces $-      "col == 0: " ++ show (len, columns)--    case filter ((<= len) . columnColumn) columns of-      c : _ | columnColumn c == len, isJust (columnKind c) -> do-        -- Align. (This happens automatically if the column is an-        -- alignment column, but c is an indentation column.)-        useColumn c-        output $ Text $ ptOpenBeginningOfLine-        output $ Text $ ptClose' c-      c : _ | columnColumn c <  len -> do-        -- Indent.-        useColumn c-        output $ Text $ ptOpenIndent c (codeBlock - columnCodeBlock c)-      _ -> return ()--  output $ MaybeColumn column---- | Split multi-lines string literals into multiple string literals--- Isolating leading spaces for the alignment machinery to work--- properly-stringLiteral :: Token -> Tokens-stringLiteral t | aspect (info t) == Just String =-  map (\ x -> t { text = x })-          $ concatMap leadingSpaces-          $ List.intersperse "\n"-          $ T.lines (text t)-  where-  leadingSpaces :: Text -> [Text]-  leadingSpaces t = [pre, suf]-    where (pre , suf) = T.span isSpaceNotNewline t--stringLiteral t = [t]----------------------------------------------------------------------------- * Main.--defaultStyFile :: String-defaultStyFile = "agda.sty"---- | Generates a LaTeX file for the given interface.------ The underlying source file is assumed to match the interface, but--- this is not checked. TODO: Fix this problem, perhaps by storing the--- source code in the interface.-generateLaTeX :: Interface -> TCM ()-generateLaTeX i = do-  let mod = toTopLevelModuleName $ iModuleName i-      hi  = iHighlighting i--  options <- TCM.commandLineOptions--  dir <- case O.optGHCiInteraction options of-    False -> return $ O.optLaTeXDir options-    True  -> do-      sourceFile <- Find.srcFilePath <$> Find.findFile mod-      return $ filePath (projectRoot sourceFile mod)-                 </> O.optLaTeXDir options-  liftIO $ createDirectoryIfMissing True dir--  (code, _, _) <- liftIO $ readProcessWithExitCode-                    "kpsewhich" [ "--path=" ++ dir,  defaultStyFile ] ""--  when (code /= ExitSuccess) $ do-    TCM.reportS "compile.latex" 1-      [ defaultStyFile ++ " was not found. Copying a default version of " ++-          defaultStyFile-      , "into " ++ dir ++ "."-      ]--    liftIO $ do-      styFile <- getDataFileName defaultStyFile-      liftIO $ copyFile styFile (dir </> defaultStyFile)--  let outPath = modToFile mod-  inAbsPath <- liftM filePath (Find.srcFilePath <$> Find.findFile mod)--  liftIO $ do-    latex <- E.encodeUtf8 `fmap`-               toLaTeX (O.optCountClusters $ O.optPragmaOptions options)-                       (mkAbsolute inAbsPath) (iSource i) hi-    createDirectoryIfMissing True $ dir </> takeDirectory outPath-    BS.writeFile (dir </> outPath) latex--  where-    modToFile :: TopLevelModuleName -> FilePath-    modToFile m = List.intercalate [pathSeparator] (moduleNameParts m) <.> "tex"--groupByFst :: forall a b. Eq a => [(a,b)] -> [(a,[b])]-groupByFst =-    map (\xs -> case xs of                     -- Float the grouping to the top level-          []           -> __IMPOSSIBLE__-          (tag, _): _ -> (tag, map snd xs))--  . List.groupBy ((==) `on` fst)  -- Group together characters in the same-                                  -- role.---- | Transforms the source code into LaTeX.-toLaTeX-  :: Bool-     -- ^ Count extended grapheme clusters?-  -> AbsolutePath-  -> L.Text-  -> HighlightingInfo-  -> IO L.Text-toLaTeX cc path source hi--  = processTokens cc--  . map (\(role, tokens) -> (role,) $-      -- This bit fixes issue 954-      (if L.isCode role then-        -- Remove trailing whitespace from the-        -- final line; the function spaces-        -- expects trailing whitespace to be-        -- followed by a newline character.-        whenMoreThanOne-          (withLast $-            withTokenText $ \suf ->-              fromMaybe suf $-                fmap (T.dropWhileEnd isSpaceNotNewline) $-                  T.stripSuffix "\n" suf)-        .-        (withLast $ withTokenText $ T.dropWhileEnd isSpaceNotNewline)-        .-        (withFirst $-          withTokenText $ \pre ->-              fromMaybe pre $-                  T.stripPrefix "\n" $-                    T.dropWhile isSpaceNotNewline pre)-      else-        -- do nothing-        id) tokens)--  . map (second (-      -- Split tokens at newlines-      concatMap stringLiteral--      -- Head the list (the grouped chars contain the same meta info) and-      -- collect the characters into a string.-    . map (\(mi, cs) ->-                          Token { text = T.pack cs-                                , info = fromMaybe mempty mi-                                })-      -- Characters which share the same meta info are the same token, so-      -- group them together.-    . groupByFst-    ))--  -- Characters in different layers belong to different tokens-  . groupByFst--  -- Look up the meta info at each position in the highlighting info.-  . map (\(pos, (role, char)) -> (role, (IntMap.lookup pos infoMap, char)))--  -- Add position in file to each character.-  . zip [1..]--  -- Map each character to its role-  . atomizeLayers . literateTeX (startPos (Just path))--  $ L.unpack source-  where-  infoMap = toMap (decompress hi)--  -- | This function preserves laziness of the list-  withLast :: (a -> a) -> [a] -> [a]-  withLast f [] = []-  withLast f [a] = [f a]-  withLast f (a:as) = a:withLast f as--  -- | This function preserves laziness of the list-  withFirst :: (a -> a) -> [a] -> [a]-  withFirst _ [] = []-  withFirst f (a:as) = f a:as--  whenMoreThanOne :: ([a] -> [a]) -> [a] -> [a]-  whenMoreThanOne f xs@(_:_:_) = f xs-  whenMoreThanOne _ xs         = xs----processTokens-  :: Bool-     -- ^ Count extended grapheme clusters?-  -> [(LayerRole, Tokens)]-  -> IO L.Text-processTokens cc ts = do-  ((), s, os) <- runLaTeX (processLayers ts) () (emptyState cc)-  return $ L.fromChunks $ map (render s) os-  where-    render _ (Text s)        = s-    render s (MaybeColumn c)-      | Just i <- columnKind c,-        not (Set.member i (usedColumns s)) = agdaSpace-      | otherwise                          = nl <+> ptOpen c+import Agda.Interaction.Highlighting.LaTeX.Backend as Exports+  ( latexBackend+  )

+ src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs view

@@ -0,0 +1,191 @@++module Agda.Interaction.Highlighting.LaTeX.Backend+  ( latexBackend+  ) where++import Agda.Interaction.Highlighting.LaTeX.Base+  ( LaTeXOptions(..)+  , LogLaTeXT+  , runLogLaTeXTWith+  , logMsgToText+  , generateLaTeXIO+  , prepareCommonAssets+  )++import Control.DeepSeq+import Control.Monad.Trans (MonadIO)++import qualified Data.Map as Map+import Data.Map (Map)++import qualified Data.Text as T++import GHC.Generics (Generic)++import System.FilePath ( (</>) )++import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..))+import Agda.Compiler.Common (curIF, IsMain(IsMain, NotMain))++import Agda.Interaction.Options+  ( ArgDescr(NoArg, ReqArg)+  , CommandLineOptions ( optGHCiInteraction, optPragmaOptions )+  , PragmaOptions ( optCountClusters )+  , Flag+  , OptDescr(..)+  )++import Agda.Syntax.Abstract.Name (ModuleName, toTopLevelModuleName)+import Agda.Syntax.Concrete.Name (TopLevelModuleName, projectRoot)++import Agda.TypeChecking.Monad+  ( HasOptions(commandLineOptions)+  , MonadDebug+  , stModuleToSource+  , useTC+  , ReadTCState+  , reportS+  )++import Agda.Utils.FileName (filePath, mkAbsolute)++------------------------------------------------------------------------+-- * Main.++-- Command-line flag options, prior to e.g. path resolution and validation.+data LaTeXFlags = LaTeXFlags+  { latexFlagOutDir        :: FilePath+  , latexFlagSourceFile    :: Maybe FilePath+  , latexFlagGenerateLaTeX :: Bool+    -- ^ Are we going to try to generate LaTeX at all?+  } deriving (Eq, Generic)++instance NFData LaTeXFlags++-- | The default output directory for LaTeX.++defaultLaTeXDir :: FilePath+defaultLaTeXDir = "latex"++defaultLaTeXFlags :: LaTeXFlags+defaultLaTeXFlags = LaTeXFlags+  { latexFlagOutDir        = defaultLaTeXDir+  , latexFlagSourceFile    = Nothing+  , latexFlagGenerateLaTeX = False+  }++latexFlagsDescriptions :: [OptDescr (Flag LaTeXFlags)]+latexFlagsDescriptions =+  [ Option []     ["latex"] (NoArg latexFlag)+                  "generate LaTeX with highlighted source code"+  , Option []     ["latex-dir"] (ReqArg latexDirFlag "DIR")+                  ("directory in which LaTeX files are placed (default: " +++                    defaultLaTeXDir ++ ")")+  ]++latexFlag :: Flag LaTeXFlags+latexFlag o = return $ o { latexFlagGenerateLaTeX = True }++latexDirFlag :: FilePath -> Flag LaTeXFlags+latexDirFlag d o = return $ o { latexFlagOutDir = d }++data LaTeXCompileEnv = LaTeXCompileEnv LaTeXFlags+data LaTeXModuleEnv  = LaTeXModuleEnv LaTeXOptions+data LaTeXModule     = LaTeXModule+data LaTeXDef        = LaTeXDef++latexBackend :: Backend+latexBackend = Backend latexBackend'++latexBackend' :: Backend' LaTeXFlags LaTeXCompileEnv LaTeXModuleEnv LaTeXModule LaTeXDef+latexBackend' = Backend'+  { backendName           = "LaTeX"+  , backendVersion        = Nothing+  , options               = defaultLaTeXFlags+  , commandLineFlags      = latexFlagsDescriptions+  , isEnabled             = latexFlagGenerateLaTeX+  , preCompile            = preCompileLaTeX+  , preModule             = preModuleLaTeX+  , compileDef            = compileDefLaTeX+  , postModule            = postModuleLaTeX+  , postCompile           = postCompileLaTeX+  , scopeCheckingSuffices = True+  , mayEraseType          = const $ return False+  }++runLogLaTeXWithMonadDebug :: MonadDebug m => LogLaTeXT m a -> m a+runLogLaTeXWithMonadDebug = runLogLaTeXTWith $ (reportS "compile.latex" 1) . T.unpack . logMsgToText++-- Resolve the raw flags into usable LaTeX options.+resolveLaTeXOptions :: (HasOptions m, ReadTCState m) => LaTeXFlags -> TopLevelModuleName -> m LaTeXOptions+resolveLaTeXOptions flags moduleName = do+  options <- commandLineOptions+  modFiles <- useTC stModuleToSource+  let+    mSrcFileName = (mkAbsolute . filePath) <$> Map.lookup moduleName modFiles+    countClusters = optCountClusters . optPragmaOptions $ options+    latexDir = latexFlagOutDir flags+    -- FIXME: This reliance on emacs-mode to decide whether to interpret the output location as project-relative or+    -- cwd-relative is gross. Also it currently behaves differently for JSON mode :-/+    -- And it prevents us from doing a real "one-time" setup.+    outDir = case (mSrcFileName, optGHCiInteraction options) of+      (Just sourceFile, True) -> filePath (projectRoot sourceFile moduleName) </> latexDir+      _ -> latexDir+  return LaTeXOptions+    { latexOptOutDir         = outDir+    , latexOptSourceFileName = mSrcFileName+    , latexOptCountClusters  = countClusters+    }++preCompileLaTeX+  :: Applicative m+  => LaTeXFlags+  -> m LaTeXCompileEnv+preCompileLaTeX flags = pure $ LaTeXCompileEnv flags++preModuleLaTeX+  :: (HasOptions m, ReadTCState m)+  => LaTeXCompileEnv+  -> IsMain+  -> ModuleName+  -> Maybe FilePath+  -> m (Recompile LaTeXModuleEnv LaTeXModule)+preModuleLaTeX (LaTeXCompileEnv flags) isMain moduleName _ifacePath = case isMain of+  IsMain  -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags (toTopLevelModuleName moduleName)+  NotMain -> return $ Skip LaTeXModule++compileDefLaTeX+  :: Applicative m+  => LaTeXCompileEnv+  -> LaTeXModuleEnv+  -> IsMain+  -> Definition+  -> m LaTeXDef+compileDefLaTeX _cenv _menv _main _def = pure LaTeXDef++postModuleLaTeX+  :: (MonadDebug m, ReadTCState m, MonadIO m)+  => LaTeXCompileEnv+  -> LaTeXModuleEnv+  -> IsMain+  -> ModuleName+  -> [LaTeXDef]+  -> m LaTeXModule+postModuleLaTeX _cenv (LaTeXModuleEnv latexOpts) _main _moduleName _defs = do+  i <- curIF+  runLogLaTeXWithMonadDebug $ do+    -- FIXME: It would be better to do "prepareCommonAssets" in @preCompileLaTeX@, but because+    -- the output directory depends on the module-relative project root (when in emacs-mode),+    -- we can't do that until we see the module.+    -- However, for now that is OK because we only generate LaTeX for the main module.+    prepareCommonAssets (latexOptOutDir latexOpts)+    generateLaTeXIO latexOpts i+  return LaTeXModule++postCompileLaTeX+  :: Applicative m+  => LaTeXCompileEnv+  -> IsMain+  -> Map ModuleName LaTeXModule+  -> m ()+postCompileLaTeX _cenv _main _modulesByName = pure ()

+ src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs view

@@ -0,0 +1,824 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++-- | Function for generating highlighted and aligned LaTeX from literate+-- Agda source.++module Agda.Interaction.Highlighting.LaTeX.Base+  ( generateLaTeXIO+  , prepareCommonAssets+  , runLogLaTeXTWith+  , logMsgToText+  , LogMessage(..)+  , MonadLogLaTeX+  , LogLaTeXT+  , LaTeXOptions(..)+  ) where++import Prelude hiding (log)+import Data.Char+import Data.Maybe+import Data.Function+import Data.Foldable (toList)+import Control.Monad.Trans.Reader as R ( ReaderT(runReaderT) )+import Control.Monad.RWS.Strict+import Control.Arrow (second)+import System.Directory+import System.Exit+import System.FilePath+import System.Process+import Data.Text (Text)+import qualified Data.Text               as T+#ifdef COUNT_CLUSTERS+import qualified Data.Text.ICU           as ICU+#endif+import qualified Data.Text.Lazy          as L+import qualified Data.Text.Lazy.Encoding as E+import qualified Data.ByteString.Lazy    as BS++import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import qualified Data.IntMap  as IntMap+import qualified Data.List    as List++import Paths_Agda++import Agda.Syntax.Abstract (toTopLevelModuleName)+import Agda.Syntax.Common+import Agda.Syntax.Concrete (TopLevelModuleName, moduleNameParts)+import Agda.Syntax.Parser.Literate (literateTeX, LayerRole, atomizeLayers)+import qualified Agda.Syntax.Parser.Literate as L+import Agda.Syntax.Position (startPos)++import Agda.Interaction.Highlighting.Precise hiding (toList)++import Agda.TypeChecking.Monad (Interface(..))++import Agda.Utils.FileName (AbsolutePath)+import Agda.Utils.List     (last1)+import qualified Agda.Utils.List1 as List1++import Agda.Utils.Impossible++------------------------------------------------------------------------+-- * Logging++class Monad m => MonadLogLaTeX m where+  logLaTeX :: LogMessage -> m ()++-- | Log LaTeX messages using a provided action.+--+-- This could be accomplished by putting logs into the RWST output and splitting it+-- into a WriterT, but that becomes slightly more complicated to reason about in+-- the presence of IO exceptions.+--+-- We want the logging to be reasonbly polymorphic, avoid space leaks that can occur+-- with WriterT, and also be usable during outer phases such as directory preparation.+--+-- I'm not certain this is the best way to do it, but whatever.+type LogLaTeXT m = ReaderT (LogMessage -> m ()) m++instance Monad m => MonadLogLaTeX (LogLaTeXT m) where+  logLaTeX message = do+    doLog <- ask+    lift $ doLog message++runLogLaTeXTWith :: Monad m => (LogMessage -> m ()) -> LogLaTeXT m a -> m a+runLogLaTeXTWith = flip runReaderT++-- Not currently used, but for example:+-- runLogLaTeXWithIO :: MonadIO m => LogLaTeXT m a -> m a+-- runLogLaTeXWithIO = runLogLaTeXTWith $ liftIO . T.putStrLn . logMsgToText++------------------------------------------------------------------------+-- * Datatypes.++-- | The @LaTeX@ monad is a combination of @ExceptT@, @RWST@ and+-- a logger @m@. The error part is just used to keep track whether we finished or+-- not, the reader part contains static options used, the writer is where the+-- output goes and the state is for keeping track of the tokens and some+-- other useful info, and the MonadLogLaTeX part is used for printing debugging info.++type LaTeX a = forall m. MonadLogLaTeX m => RWST Env [Output] State m a++-- | Output items.++data LogMessage = LogMessage Debug Text [Text] deriving Show++data Output+  = Text !Text+    -- ^ A piece of text.+  | MaybeColumn !AlignmentColumn+    -- ^ A column. If it turns out to be an indentation column that is+    --   not used to indent or align something, then no column will be+    --   generated, only whitespace ('agdaSpace').+  deriving Show++-- | Column kinds.++data Kind+  = Indentation+    -- ^ Used only for indentation (the placement of the first token+    -- on a line, relative to tokens on previous lines).+  | Alignment+    -- ^ Used both for indentation and for alignment.+  deriving (Eq, Show)++-- | Unique identifiers for indentation columns.++type IndentationColumnId = Int++-- | Alignment and indentation columns.++data AlignmentColumn = AlignmentColumn+  { columnCodeBlock :: !Int+    -- ^ The column's code block.+  , columnColumn :: !Int+    -- ^ The column number.+  , columnKind :: Maybe IndentationColumnId+    -- ^ The column kind. 'Nothing' for alignment columns and @'Just'+    -- i@ for indentation columns, where @i@ is the column's unique+    -- identifier.+  } deriving Show++-- | Type of function for estimating column width of text.++type TextWidthEstimator = Text -> Int++data Env = Env+  { estimateTextWidth :: !TextWidthEstimator+    -- ^ How to estimate the column width of text (i.e. Count extended grapheme clusters vs. code points).+  , debugs :: [Debug]+    -- ^ Says what debug information should printed.+  }++data State = State+  { codeBlock     :: !Int   -- ^ The number of the current code block.+  , column        :: !Int   -- ^ The current column number.+  , columns       :: [AlignmentColumn]+                            -- ^ All alignment columns found on the+                            --   current line (so far), in reverse+                            --   order.+  , columnsPrev   :: [AlignmentColumn]+                            -- ^ All alignment columns found in+                            --   previous lines (in any code block),+                            --   with larger columns coming first.+  , nextId        :: !IndentationColumnId+                            -- ^ The next indentation column+                            -- identifier.+  , usedColumns   :: HashSet IndentationColumnId+                            -- ^ Indentation columns that have+                            -- actually+                            --   been used.+  }++type Tokens = [Token]++data Token = Token+  { text     :: !Text+  , info     :: Aspects+  }+  deriving Show++withTokenText :: (Text -> Text) -> Token -> Token+withTokenText f tok@Token{text = t} = tok{text = f t}++data Debug = MoveColumn | NonCode | Code | Spaces | Output | FileSystem+  deriving (Eq, Show)++-- | Run function for the @LaTeX@ monad.+runLaTeX :: MonadLogLaTeX m =>+  LaTeX a -> Env -> State -> m (a, State, [Output])+-- ASR (2021-02-07). The eta-expansion is required by GHC >= 9.0.1+-- (see Issue #4955).+runLaTeX l = runRWST l++emptyState :: State+emptyState = State+  { codeBlock     = 0+  , column        = 0+  , columns       = []+  , columnsPrev   = []+  , nextId        = 0+  , usedColumns   = Set.empty+  }++emptyEnv+  :: TextWidthEstimator  -- ^ Count extended grapheme clusters?+  -> Env+emptyEnv twe = Env twe []+++------------------------------------------------------------------------+-- * Some helpers.++-- | Gives the size of the string. If cluster counting is enabled,+-- then the number of extended grapheme clusters is computed (the root+-- locale is used), and otherwise the number of code points.++size :: Text -> LaTeX Int+size t = do+  f <- estimateTextWidth <$> ask+  return $ f t++(<+>) :: Text -> Text -> Text+(<+>) = T.append++-- | Does the string consist solely of whitespace?++isSpaces :: Text -> Bool+isSpaces = T.all isSpace++-- | Is the character a whitespace character distinct from '\n'?++isSpaceNotNewline :: Char -> Bool+isSpaceNotNewline c = isSpace c && c /= '\n'++-- | Replaces all forms of whitespace, except for new-line characters,+-- with spaces.++replaceSpaces :: Text -> Text+replaceSpaces = T.map (\c -> if isSpaceNotNewline c then ' ' else c)+++-- | If the `Token` consists of spaces, the internal column counter is advanced+--   by the length of the token. Otherwise, `moveColumnForToken` is a no-op.+moveColumnForToken :: Token -> LaTeX ()+moveColumnForToken t = do+  unless (isSpaces (text t)) $ do+    log MoveColumn $ text t+    -- ASR (2021-02-07). The eta-expansion is required by GHC >= 9.0.1+    -- (see Issue #4955).+    (\n -> moveColumn n) =<< size (text t)++-- | Merges 'columns' into 'columnsPrev', resets 'column' and+-- 'columns'++resetColumn :: LaTeX ()+resetColumn = modify $ \s ->+  s { column      = 0+    , columnsPrev = mergeCols (columns s) (columnsPrev s)+    , columns     = []+    }+  where+  -- Remove shadowed columns from old.+  mergeCols []         old = old+  mergeCols new@(n:ns) old = new ++ filter ((< leastNew) . columnColumn) old+    where+    leastNew = columnColumn (last1 n ns)++moveColumn :: Int -> LaTeX ()+moveColumn i = modify $ \s -> s { column = i + column s }++-- | Registers a column of the given kind. The column is returned.++registerColumn :: Kind -> LaTeX AlignmentColumn+registerColumn kind = do+  column    <- gets column+  codeBlock <- gets codeBlock+  colKind   <- case kind of+                 Alignment   -> return Nothing+                 Indentation -> do+                   nextId <- gets nextId+                   modify $ \s -> s { nextId = succ nextId }+                   return (Just nextId)+  let c = AlignmentColumn { columnColumn    = column+                          , columnCodeBlock = codeBlock+                          , columnKind      = colKind+                          }+  modify $ \s -> s { columns = c : columns s }+  return c++-- | Registers the given column as used (if it is an indentation+-- column).++useColumn :: AlignmentColumn -> LaTeX ()+useColumn c = case columnKind c of+  Nothing -> return ()+  Just i  -> modify $ \s ->+               s { usedColumns = Set.insert i (usedColumns s) }++-- | Alignment column zero in the current code block.++columnZero :: LaTeX AlignmentColumn+columnZero = do+  codeBlock <- gets codeBlock+  return $ AlignmentColumn { columnColumn    = 0+                           , columnCodeBlock = codeBlock+                           , columnKind      = Nothing+                           }++-- | Registers column zero as an alignment column.++registerColumnZero :: LaTeX ()+registerColumnZero = do+  c <- columnZero+  modify $ \s -> s { columns = [c] }++-- | Changes to the state that are performed at the start of a code+-- block.++enterCode :: LaTeX ()+enterCode = do+  resetColumn+  modify $ \s -> s { codeBlock = codeBlock s + 1 }++-- | Changes to the state that are performed at the end of a code+-- block.++leaveCode :: LaTeX ()+leaveCode = return ()++tshow :: Show a => a -> Text+tshow = T.pack . show++logMsgToText :: LogMessage -> Text+logMsgToText (LogMessage messageLabel text extra) = T.concat $+  [ tshow messageLabel, ": '", text, "' "+  ] ++ if null extra then [] else ["(", T.unwords extra, ")"]++logHelper :: Debug -> Text -> [Text] -> LaTeX ()+logHelper debug text extra = do+  logLevels <- debugs <$> ask+  when (debug `elem` logLevels) $ do+    lift $ logLaTeX (LogMessage debug text extra)++log :: Debug -> Text -> LaTeX ()+log MoveColumn text = do+  cols <- gets columns+  logHelper MoveColumn text ["columns=", tshow cols]+log Code text = do+  cols <- gets columns+  col <- gets column+  logHelper Code text ["columns=", tshow cols, "col=", tshow col]+log debug text = logHelper debug text []++output :: Output -> LaTeX ()+output item = do+  log Output (T.pack $ show item)+  tell [item]++------------------------------------------------------------------------+-- * LaTeX and polytable strings.++-- Polytable, http://www.ctan.org/pkg/polytable, is used for code+-- alignment, similar to lhs2TeX's approach.++nl :: Text+nl = "%\n"++-- | A command that is used when two tokens are put next to each other+-- in the same column.++agdaSpace :: Text+agdaSpace = cmdPrefix <+> "Space" <+> cmdArg T.empty <+> nl++-- | The column's name.+--+-- Indentation columns have unique names, distinct from all alignment+-- column names.++columnName :: AlignmentColumn -> Text+columnName c = T.pack $ case columnKind c of+  Nothing -> show (columnColumn c)+  Just i  -> show i ++ "I"++-- | Opens a column with the given name.++ptOpen' :: Text -> Text+ptOpen' name = "\\>[" <+> name <+> "]"++-- | Opens the given column.++ptOpen :: AlignmentColumn -> Text+ptOpen c = ptOpen' (columnName c)++-- | Opens a special column that is only used at the beginning of+-- lines.++ptOpenBeginningOfLine :: Text+ptOpenBeginningOfLine = ptOpen' "." <+> "[@{}l@{}]"++-- | Opens the given column, and inserts an indentation instruction+-- with the given argument at the end of it.++ptOpenIndent+  :: AlignmentColumn+  -> Int              -- ^ Indentation instruction argument.+  -> Text+ptOpenIndent c delta =+  ptOpen c <+> "[@{}l@{"+           <+> cmdPrefix+           <+> "Indent"+           <+> cmdArg (T.pack $ show delta)+           <+> "}]"++ptClose :: Text+ptClose = "\\<"++ptClose' :: AlignmentColumn -> Text+ptClose' c =+  ptClose <+> "[" <+> columnName c <+> "]"++ptNL :: Text+ptNL = nl <+> "\\\\\n"++ptEmptyLine :: Text+ptEmptyLine =+  nl <+> "\\\\["+     <+> cmdPrefix+     <+> "EmptyExtraSkip"+     <+> "]%\n"++cmdPrefix :: Text+cmdPrefix = "\\Agda"++cmdArg :: Text -> Text+cmdArg x = "{" <+> x <+> "}"++------------------------------------------------------------------------+-- * Output generation from a stream of labelled tokens.++processLayers :: [(LayerRole, Tokens)] -> LaTeX ()+-- ASR (2021-02-07). The eta-expansion on @lt@ is required by GHC >=+-- 9.0.1 (see Issue #4955).+processLayers lt = (mapM_ $ \(layerRole,toks) -> do+  case layerRole of+    L.Markup  -> processMarkup  toks+    L.Comment -> processComment toks+    L.Code    -> processCode    toks) lt++processMarkup, processComment, processCode :: Tokens -> LaTeX ()++-- | Deals with markup, which is output verbatim.+-- ASR (2021-02-07). The eta-expansion on @t@ is required by GHC >=+-- 9.0.1 (see Issue #4955).+processMarkup t = (mapM_ $ \t' -> do+  moveColumnForToken t'+  output (Text (text t'))) t++-- | Deals with literate text, which is output verbatim+-- ASR (2021-02-07). The eta-expansion with @t@ is required by GHC >=+-- 9.0.1 (see Issue #4955).+processComment t = (mapM_ $ \t' -> do+  unless ("%" == T.take 1 (T.stripStart (text t'))) $ do+    moveColumnForToken t'+  output (Text (text t'))) t++-- | Deals with code blocks. Every token, except spaces, is pretty+-- printed as a LaTeX command.+processCode toks' = do+  output $ Text nl+  enterCode+  mapM_ go toks'+  ptOpenWhenColumnZero =<< gets column+  output $ Text $ ptClose <+> nl+  leaveCode++  where+    go tok' = do+      -- Get the column information before grabbing the token, since+      -- grabbing (possibly) moves the column.+      col  <- gets column++      moveColumnForToken tok'+      let tok = text tok'+      log Code tok++      if (tok == T.empty) then return ()+      else do+        if (isSpaces tok) then do+            spaces $ T.group $ replaceSpaces tok+        else do+          ptOpenWhenColumnZero col+          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)+                  (escape tok)+                  $ map fromOtherAspect (toList $ otherAspects $ info tok') +++                    concatMap fromAspect (toList $ aspect $ info tok')++    -- Non-whitespace tokens at the start of a line trigger an+    -- alignment column.+    ptOpenWhenColumnZero col =+        when (col == 0) $ do+          registerColumnZero+          -- ASR (2021-02-07). The eta-expansion @\o -> output o@ is+          -- required by GHC >= 9.0.1 (see Issue #4955).+          (\o -> output o). Text . ptOpen =<< columnZero++    -- 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++    fromAspect :: Aspect -> [String]+    fromAspect a = let s = [show a] in case a of+      Comment           -> s+      Keyword           -> s+      Hole              -> s+      String            -> s+      Number            -> s+      Symbol            -> s+      PrimitiveType     -> s+      Pragma            -> s+      Background        -> s+      Markup            -> s+      Name Nothing isOp -> fromAspect (Name (Just Postulate) isOp)+        -- At the time of writing the case above can be encountered in+        -- --only-scope-checking mode, for instance for the token "Size"+        -- in the following code:+        --+        --   {-# BUILTIN SIZE Size #-}+        --+        -- 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+          Bound                     -> sk+          Generalizable             -> sk+          Constructor Inductive     -> "InductiveConstructor"+          Constructor CoInductive   -> "CoinductiveConstructor"+          Datatype                  -> sk+          Field                     -> sk+          Function                  -> sk+          Module                    -> sk+          Postulate                 -> sk+          Primitive                 -> sk+          Record                    -> sk+          Argument                  -> sk+          Macro                     -> sk+        where+        sk = show kind++-- | Escapes special characters.+escape :: Text -> Text+escape (T.uncons -> Nothing)     = T.empty+escape (T.uncons -> Just (c, s)) = T.pack (replace c) <+> escape s+  where+  replace :: Char -> String+  replace char = case char of+    '_'  -> "\\AgdaUnderscore{}"+    '{'  -> "\\{"+    '}'  -> "\\}"+    '#'  -> "\\#"+    '$'  -> "\\$"+    '&'  -> "\\&"+    '%'  -> "\\%"+    '~'  -> "\\textasciitilde{}"+    '^'  -> "\\textasciicircum{}"+    '\\' -> "\\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+-- list elements must not contain the same character.+--+-- If the final element of the list consists of spaces, then these+-- spaces are assumed to not be trailing whitespace.+spaces :: [Text] -> LaTeX ()+spaces [] = return ()++-- Newlines.+spaces (s@(T.uncons -> Just ('\n', _)) : ss) = do+  col <- gets column+  when (col == 0) $+    -- ASR (2021-02-07). The eta-expansion @\o -> output o@ is+    -- required by GHC >= 9.0.1 (see Issue #4955).+    (\o -> output o) . Text . ptOpen =<< columnZero+  output $ Text $ ptClose <+> ptNL <+>+                  T.replicate (T.length s - 1) ptEmptyLine+  resetColumn+  spaces ss++-- Spaces followed by a newline character.+spaces (_ : ss@(_ : _)) = spaces ss++-- Spaces that are not followed by a newline character.+spaces [ s ] = do+  col <- gets column++  let len  = T.length s+      kind = if col /= 0 && len == 1+             then Indentation+             else Alignment++  moveColumn len+  column <- registerColumn kind++  if col /= 0+  then log Spaces "col /= 0"+  else do+    columns    <- gets columnsPrev+    codeBlock  <- gets codeBlock++    log Spaces $+      "col == 0: " <+> T.pack (show (len, columns))++    case filter ((<= len) . columnColumn) columns of+      c : _ | columnColumn c == len, isJust (columnKind c) -> do+        -- Align. (This happens automatically if the column is an+        -- alignment column, but c is an indentation column.)+        useColumn c+        output $ Text $ ptOpenBeginningOfLine+        output $ Text $ ptClose' c+      c : _ | columnColumn c <  len -> do+        -- Indent.+        useColumn c+        output $ Text $ ptOpenIndent c (codeBlock - columnCodeBlock c)+      _ -> return ()++  output $ MaybeColumn column++-- | Split multi-lines string literals into multiple string literals+-- Isolating leading spaces for the alignment machinery to work+-- properly+stringLiteral :: Token -> Tokens+stringLiteral t | aspect (info t) == Just String =+  map (\ x -> t { text = x })+          $ concatMap leadingSpaces+          $ List.intersperse "\n"+          $ T.lines (text t)+  where+  leadingSpaces :: Text -> [Text]+  leadingSpaces tok = [pre, suf]+    where (pre , suf) = T.span isSpaceNotNewline tok++stringLiteral t = [t]++------------------------------------------------------------------------+-- * Main.++defaultStyFile :: String+defaultStyFile = "agda.sty"++data LaTeXOptions = LaTeXOptions+  { latexOptOutDir         :: FilePath+  , latexOptSourceFileName :: Maybe AbsolutePath+    -- ^ The parser uses a @Position@ which includes a source filename for+    -- error reporting and such. We don't actually get the source filename+    -- with an @Interface@, and it isn't necessary to look it up.+    -- This is a "nice-to-have" parameter.+  , latexOptCountClusters  :: Bool+    -- ^ Count extended grapheme clusters rather than code points when+    -- generating LaTeX.+  }++getTextWidthEstimator :: Bool -> TextWidthEstimator+getTextWidthEstimator _countClusters =+#ifdef COUNT_CLUSTERS+  if _countClusters+    then length . (ICU.breaks (ICU.breakCharacter ICU.Root))+    else T.length+#else+  T.length+#endif++-- | Create the common base output directory and check for/install the style file.+prepareCommonAssets :: (MonadLogLaTeX m, MonadIO m) => FilePath -> m ()+prepareCommonAssets dir = do+  liftIO $ createDirectoryIfMissing True dir+  (code, _, _) <-+    liftIO $+      readProcessWithExitCode+        "kpsewhich"+        ["--path=" ++ dir, defaultStyFile]+        ""+  when (code /= ExitSuccess) $ do+    logLaTeX $ LogMessage FileSystem+      (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir])+      []+    liftIO $ do+      styFile <- getDataFileName defaultStyFile+      copyFile styFile (dir </> defaultStyFile)++-- | Generates a LaTeX file for the given interface.+generateLaTeXIO :: (MonadLogLaTeX m, MonadIO m) => LaTeXOptions -> Interface -> m ()+generateLaTeXIO opts i = do+  let textWidthEstimator = getTextWidthEstimator (latexOptCountClusters opts)+  let baseDir = latexOptOutDir opts+  let outPath = baseDir </> (latexOutRelativeFilePath $ toTopLevelModuleName $ iModuleName i)+  latex <- E.encodeUtf8 <$> toLaTeX+              (emptyEnv textWidthEstimator)+              (latexOptSourceFileName opts)+              (iSource i)+              (iHighlighting i)+  liftIO $ do+    createDirectoryIfMissing True (takeDirectory outPath)+    BS.writeFile outPath latex++latexOutRelativeFilePath :: TopLevelModuleName -> FilePath+latexOutRelativeFilePath m = List.intercalate [pathSeparator] (List1.toList $ moduleNameParts m) <.> "tex"++groupByFst :: forall a b. Eq a => [(a,b)] -> [(a,[b])]+groupByFst =+    map (\xs -> case xs of                     -- Float the grouping to the top level+          []           -> __IMPOSSIBLE__+          (tag, _): _ -> (tag, map snd xs))++  . List.groupBy ((==) `on` fst)  -- Group together characters in the same+                                  -- role.++-- | Transforms the source code into LaTeX.+toLaTeX+  :: MonadLogLaTeX m+  => Env+  -> Maybe AbsolutePath+  -> L.Text+  -> HighlightingInfo+  -> m L.Text+toLaTeX env path source hi =++  processTokens env++    . map+      ( ( \(role, tokens) ->+            (role,) $+              -- This bit fixes issue 954+              ( if L.isCode role+                  then-- Remove trailing whitespace from the+                  -- final line; the function spaces+                  -- expects trailing whitespace to be+                  -- followed by a newline character.+                    whenMoreThanOne+                      ( withLast+                          $ withTokenText+                          $ \suf ->+                            maybe+                              suf+                              (T.dropWhileEnd isSpaceNotNewline)+                              (T.stripSuffix "\n" suf)+                      )+                      . withLast (withTokenText $ T.dropWhileEnd isSpaceNotNewline)+                      . withFirst+                        ( withTokenText $+                            \pre ->+                              fromMaybe pre $ T.stripPrefix "\n" $+                                T.dropWhile+                                  isSpaceNotNewline+                                  pre+                        )+                  else-- do nothing+                    id+              )+                tokens+        ) . ( second+                ( -- Split tokens at newlines+                  concatMap+                    ( stringLiteral+                        . ( \(mi, cs) ->+                              Token {text = T.pack cs, info = fromMaybe mempty mi}+                          )+                    )+                    . groupByFst+                )+            )+      )+    . groupByFst++  -- Look up the meta info at each position in the highlighting info.+  . zipWith (\pos (role, char) -> (role, (IntMap.lookup pos infoMap, char)))+            [1..] . -- Add position in file to each character.+              -- Map each character to its role+              atomizeLayers . literateTeX (startPos path)++  $ L.unpack source+  where+  infoMap = toMap hi++  -- This function preserves laziness of the list+  withLast :: (a -> a) -> [a] -> [a]+  withLast _ [] = []+  withLast f [a] = [f a]+  withLast f (a:as) = a:withLast f as++  -- This function preserves laziness of the list+  withFirst :: (a -> a) -> [a] -> [a]+  withFirst _ [] = []+  withFirst f (a:as) = f a:as++  whenMoreThanOne :: ([a] -> [a]) -> [a] -> [a]+  whenMoreThanOne f xs@(_:_:_) = f xs+  whenMoreThanOne _ xs         = xs+++processTokens+  :: MonadLogLaTeX m+  => Env+  -> [(LayerRole, Tokens)]+  -> m L.Text+processTokens env ts = do+  ((), s, os) <- runLaTeX (processLayers ts) env emptyState+  return $ L.fromChunks $ map (render s) os+  where+    render _ (Text s)        = s+    render s (MaybeColumn c)+      | Just i <- columnKind c,+        not (Set.member i (usedColumns s)) = agdaSpace+      | otherwise                          = nl <+> ptOpen c

src/full/Agda/Interaction/Highlighting/Precise.hs view

@@ -1,69 +1,73 @@-{-# LANGUAGE CPP                        #-} -- | Types used for precise syntax highlighting.  module Agda.Interaction.Highlighting.Precise-  ( -- * Files+  ( -- * Highlighting information     Aspect(..)   , NameKind(..)   , OtherAspect(..)   , Aspects(..)   , DefinitionSite(..)   , TokenBased(..)-  , File(..)+  , RangePair(..)+  , rangePairInvariant+  , PositionMap(..)+  , DelayedMerge(..)+  , delayedMergeInvariant   , HighlightingInfo-    -- ** Creation+  , highlightingInfoInvariant+  , HighlightingInfoBuilder+  , highlightingInfoBuilderInvariant+    -- ** Operations   , parserBased-  , singleton-  , several-    -- ** Merging-  , merge-    -- ** Inspection-  , smallestPos-  , toMap-    -- * Compressed files-  , CompressedFile(..)-  , compressedFileInvariant-  , compress-  , decompress-  , noHighlightingInRange-    -- ** Creation-  , singletonC-  , severalC-  , splitAtC-  , selectC-    -- ** Inspection-  , smallestPosC-    -- ** Merge-  , mergeC+  , kindOfNameToNameKind+  , IsBasicRangeMap(..)+  , RangeMap.several+  , Convert(..)+  , RangeMap.insideAndOutside+  , RangeMap.restrictTo   ) where +import Prelude hiding (null)+ import Control.Arrow (second)+import Control.DeepSeq import Control.Monad  import Data.Function import qualified Data.List as List import Data.Maybe-#if __GLASGOW_HASKELL__ < 804 import Data.Semigroup-#endif  import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+ import Data.Set (Set) import qualified Data.Set as Set +import GHC.Generics (Generic)+ import qualified Agda.Syntax.Position as P-import qualified Agda.Syntax.Common as Common-import qualified Agda.Syntax.Concrete as SC+import qualified Agda.Syntax.Common   as Common+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Scope.Base                   ( KindOfName(..) )  import Agda.Interaction.Highlighting.Range -import Agda.Utils.String import Agda.Utils.List+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Null+import Agda.Utils.RangeMap (RangeMap, IsBasicRangeMap(..))+import qualified Agda.Utils.RangeMap as RangeMap+import Agda.Utils.String +import Agda.Utils.Impossible+ --------------------------------------------------------------------------- Files+-- Highlighting information  -- | Syntactic aspects of the code. (These cannot overlap.) @@ -72,6 +76,7 @@   | Keyword   | String   | Number+  | Hole   | Symbol                     -- ^ Symbols like forall, =, ->, etc.   | PrimitiveType              -- ^ Things like Set and Prop.   | Name (Maybe NameKind) Bool -- ^ Is the name an operator part?@@ -82,7 +87,7 @@   | Markup     -- ^ Delimiters used to separate the Agda code blocks from the     -- other contents in literate Agda-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)  -- | @NameKind@s are figured out during scope checking. @@ -102,13 +107,15 @@   | Record                        -- ^ Record type.   | Argument                      -- ^ Named argument, like x in {x = v}   | Macro                         -- ^ Macro.-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)  -- | Other aspects, generated by type checking. --   (These can overlap with each other and with 'Aspect's.)  data OtherAspect   = Error+  | ErrorWarning+    -- ^ A warning that is considered fatal in the end.   | DottedPattern   | UnsolvedMeta   | UnsolvedConstraint@@ -133,7 +140,7 @@   -- more important, aspects in the emacs mode.   | CatchallClause   | ConfluenceProblem-    deriving (Eq, Ord, Show, Enum, Bounded)+    deriving (Eq, Ord, Show, Enum, Bounded, Generic)  -- | Meta information which can be associated with a -- character\/character range.@@ -141,8 +148,8 @@ data Aspects = Aspects   { aspect       :: Maybe Aspect   , otherAspects :: Set OtherAspect-  , note         :: Maybe String-    -- ^ This note, if present, can be displayed as a tool-tip or+  , note         :: String+    -- ^ This note, if not null, can be displayed as a tool-tip or     -- something like that. It should contain useful information about     -- the range (like the module containing a certain identifier, or     -- the fixity of an operator).@@ -152,10 +159,10 @@   , tokenBased :: !TokenBased     -- ^ Is this entry token-based?   }-  deriving Show+  deriving (Show, Generic)  data DefinitionSite = DefinitionSite-  { defSiteModule :: SC.TopLevelModuleName+  { defSiteModule :: C.TopLevelModuleName       -- ^ The defining module.   , defSitePos    :: Int       -- ^ The file position in that module. File positions are@@ -165,7 +172,7 @@   , defSiteAnchor :: Maybe String       -- ^ A pretty name for the HTML linking.   }-  deriving Show+  deriving (Show, Generic)  instance Eq DefinitionSite where   DefinitionSite m p _ _ == DefinitionSite m' p' _ _ = m == m' && p == p'@@ -180,19 +187,102 @@   Aspects a o _ d t == Aspects a' o' _ d' t' =     (a, o, d, t) == (a', o', d', t') --- | A 'File' is a mapping from file positions to meta information.+-- | A limited kind of syntax highlighting information: a pair+-- consisting of 'Ranges' and 'Aspects'. --+-- Note the invariant which 'RangePair's should satisfy+-- ('rangePairInvariant').++newtype RangePair = RangePair+  { rangePair :: (Ranges, Aspects)+  }+  deriving (Show, NFData)++-- | Invariant for 'RangePair'.++rangePairInvariant :: RangePair -> Bool+rangePairInvariant (RangePair (rs, _)) =+  rangesInvariant rs++-- | Syntax highlighting information, represented by maps from+-- positions to 'Aspects'.+-- -- The first position in the file has number 1. -newtype File = File { mapping :: IntMap Aspects }-  deriving (Eq, Show)+newtype PositionMap = PositionMap+  { positionMap :: IntMap Aspects+  }+  deriving (Show, NFData) --- | Syntax highlighting information.+-- | Highlighting info with delayed merging.+--+-- Merging large sets of highlighting info repeatedly might be costly.+-- The idea of this type is to accumulate small pieces of highlighting+-- information, and then to merge them all at the end.+--+-- Note the invariant which values of this type should satisfy+-- ('delayedMergeInvariant'). -type HighlightingInfo = CompressedFile+newtype DelayedMerge hl = DelayedMerge (Endo [hl])+  deriving (Semigroup, Monoid) +instance Show hl => Show (DelayedMerge hl) where+  showsPrec _ (DelayedMerge f) =+    showString "DelayedMerge (Endo (" .+    shows (appEndo f []) .+    showString " ++))"++-- | Invariant for @'DelayedMerge' hl@, parametrised by the invariant+-- for @hl@.+--+-- Additionally the endofunction should be extensionally equal to @(fs+-- '++')@ for some list @fs@.++delayedMergeInvariant :: (hl -> Bool) -> DelayedMerge hl -> Bool+delayedMergeInvariant inv (DelayedMerge f) =+  all inv (appEndo f [])++-- | Highlighting information.+--+-- Note the invariant which values of this type should satisfy+-- ('highlightingInfoInvariant').+--+-- This is a type synonym in order to make it easy to change to+-- another representation.++type HighlightingInfo = RangeMap Aspects++-- | The invariant for 'HighlightingInfo'.++highlightingInfoInvariant :: HighlightingInfo -> Bool+highlightingInfoInvariant = RangeMap.rangeMapInvariant++-- | A type that is intended to be used when constructing highlighting+-- information.+--+-- Note the invariant which values of this type should satisfy+-- ('highlightingInfoBuilderInvariant').+--+-- This is a type synonym in order to make it easy to change to+-- another representation.+--+-- The type should be an instance of @'IsBasicRangeMap' 'Aspects'@,+-- 'Semigroup' and 'Monoid', and there should be an instance of+-- @'Convert' 'HighlightingInfoBuilder' 'HighlightingInfo'@.++type HighlightingInfoBuilder = DelayedMerge RangePair++-- | The invariant for 'HighlightingInfoBuilder'.+--+-- Additionally the endofunction should be extensionally equal to @(fs+-- '++')@ for some list @fs@.++highlightingInfoBuilderInvariant :: HighlightingInfoBuilder -> Bool+highlightingInfoBuilderInvariant =+  delayedMergeInvariant rangePairInvariant+ --------------------------------------------------------------------------- Creation+-- Creation and conversion  -- | A variant of 'mempty' with 'tokenBased' set to -- 'NotOnlyTokenBased'.@@ -200,18 +290,104 @@ parserBased :: Aspects parserBased = mempty { tokenBased = NotOnlyTokenBased } --- | @'singleton' rs m@ is a file whose positions are those in @rs@,--- and in which every position is associated with @m@.+-- | Conversion from classification of the scope checker. -singleton :: Ranges -> Aspects -> File-singleton rs m = File {- mapping = IntMap.fromAscList [ (p, m) | p <- rangesToPositions rs ] }+kindOfNameToNameKind :: KindOfName -> NameKind+kindOfNameToNameKind = \case+  -- Inductive is Constructor default, overwritten by CoInductive+  ConName                  -> Constructor Common.Inductive+  CoConName                -> Constructor Common.CoInductive+  FldName                  -> Field+  PatternSynName           -> Constructor Common.Inductive+  GeneralizeName           -> Generalizable+  DisallowedGeneralizeName -> Generalizable+  MacroName                -> Macro+  QuotableName             -> Function+  DataName                 -> Datatype+  RecName                  -> Record+  FunName                  -> Function+  AxiomName                -> Postulate+  PrimName                 -> Primitive+  OtherDefName             -> Function --- | Like 'singleton', but with several 'Ranges' instead of only one.+instance IsBasicRangeMap Aspects RangePair where+  singleton rs m = RangePair (rs, m) -several :: [Ranges] -> Aspects -> File-several rs m = mconcat $ map (\r -> singleton r m) rs+  toList (RangePair (Ranges rs, m)) =+    [ (r, m) | r <- rs, not (null r) ] +  toMap f = toMap (convert (DelayedMerge (Endo (f :))) :: PositionMap)++instance IsBasicRangeMap Aspects PositionMap where+  singleton rs m = PositionMap+    { positionMap =+      IntMap.fromDistinctAscList [ (p, m) | p <- rangesToPositions rs ]+    }++  toList = map join . List1.groupBy' p . IntMap.toAscList . positionMap+    where+    p (pos1, m1) (pos2, m2) = pos2 == pos1 + 1 && m1 == m2+    join pms = ( Range { from = List1.head ps, to = List1.last ps + 1 }+               , List1.head ms+               )+      where (ps, ms) = List1.unzip pms++  toMap = positionMap++instance Semigroup a =>+         IsBasicRangeMap a (DelayedMerge (RangeMap a)) where+  singleton r m = DelayedMerge (Endo (singleton r m :))++  toMap  f = toMap  (convert f :: RangeMap a)+  toList f = toList (convert f :: RangeMap a)++instance IsBasicRangeMap Aspects (DelayedMerge RangePair) where+  singleton r m = DelayedMerge (Endo (singleton r m :))++  toMap  f = toMap  (convert f :: PositionMap)+  toList f = toList (convert f :: RangeMap Aspects)++instance IsBasicRangeMap Aspects (DelayedMerge PositionMap) where+  singleton r m = DelayedMerge (Endo (singleton r m :))++  toMap  f = toMap  (convert f :: PositionMap)+  toList f = toList (convert f :: PositionMap)++-- | Conversion between different types.++class Convert a b where+  convert :: a -> b++instance Monoid hl => Convert (DelayedMerge hl) hl where+  convert (DelayedMerge f) = mconcat (appEndo f [])++instance Convert (RangeMap Aspects) (RangeMap Aspects) where+  convert = id++instance Convert PositionMap (RangeMap Aspects) where+  convert =+    RangeMap.fromNonOverlappingNonEmptyAscendingList .+    toList++instance Convert (DelayedMerge PositionMap) (RangeMap Aspects) where+  convert f = convert (convert f :: PositionMap)++instance Convert (DelayedMerge RangePair) PositionMap where+  convert (DelayedMerge f) =+    PositionMap $+    IntMap.fromListWith (flip (<>))+      [ (p, m)+      | RangePair (r, m) <- appEndo f []+      , p                <- rangesToPositions r+      ]++instance Convert (DelayedMerge RangePair) (RangeMap Aspects) where+  convert (DelayedMerge f) =+    mconcat+      [ singleton r m+      | RangePair (r, m) <- appEndo f []+      ]+ ------------------------------------------------------------------------ -- Merging @@ -223,21 +399,45 @@   mempty  = TokenBased   mappend = (<>) +-- | Some 'NameKind's are more informative than others.+instance Semigroup NameKind where+  -- During scope-checking of record, we build a constructor+  -- whose arguments (@Bound@ variables) are the fields.+  -- Later, we process them as @Field@s proper.+  Field    <> Bound    = Field+  Bound    <> Field    = Field+  -- -- Projections are special functions.+  -- -- TODO necessary?+  -- Field    <> Function = Field+  -- Function <> Field    = Field+  -- TODO: more overwrites?+  k1 <> k2 | k1 == k2  = k1+           | otherwise = k1 -- TODO: __IMPOSSIBLE__++-- | @NameKind@ in @Name@ can get more precise.+instance Semigroup Aspect where+  Name mk1 op1 <> Name mk2 op2 = Name (unionMaybeWith (<>) mk1 mk2) op1+    -- (op1 || op2) breaks associativity+  a1 <> a2 | a1 == a2  = a1+           | otherwise = a1 -- TODO: __IMPOSSIBLE__++instance Semigroup DefinitionSite where+  d1 <> d2 | d1 == d2  = d1+           | otherwise = d1 -- TODO: __IMPOSSIBLE__+ -- | Merges meta information.  mergeAspects :: Aspects -> Aspects -> Aspects mergeAspects m1 m2 = Aspects-  { aspect       = (mplus `on` aspect) m1 m2+  { aspect       = (unionMaybeWith (<>) `on` aspect) m1 m2   , otherAspects = (Set.union `on` otherAspects) m1 m2   , note         = case (note m1, note m2) of-      (Just n1, Just n2) -> Just $-         if n1 == n2-           then n1-           else addFinalNewLine n1 ++ "----\n" ++ n2-      (Just n1, Nothing) -> Just n1-      (Nothing, Just n2) -> Just n2-      (Nothing, Nothing) -> Nothing-  , definitionSite = (mplus `on` definitionSite) m1 m2+      (n1, "") -> n1+      ("", n2) -> n2+      (n1, n2)+        | n1 == n2  -> n1+        | otherwise -> addFinalNewLine n1 ++ "----\n" ++ n2+  , definitionSite = (unionMaybeWith (<>) `on` definitionSite) m1 m2   , tokenBased     = tokenBased m1 <> tokenBased m2   } @@ -248,178 +448,27 @@   mempty = Aspects     { aspect         = Nothing     , otherAspects   = Set.empty-    , note           = Nothing+    , note           = []     , definitionSite = Nothing     , tokenBased     = mempty     }   mappend = (<>) --- | Merges files.--merge :: File -> File -> File-merge f1 f2 =-  File { mapping = (IntMap.unionWith mappend `on` mapping) f1 f2 }--instance Semigroup File where-  (<>) = merge+instance Semigroup PositionMap where+  f1 <> f2 = PositionMap+    { positionMap = (IntMap.unionWith mappend `on` positionMap) f1 f2 } -instance Monoid File where-  mempty  = File { mapping = IntMap.empty }+instance Monoid PositionMap where+  mempty  = PositionMap { positionMap = IntMap.empty }   mappend = (<>)  --------------------------------------------------------------------------- Inspection---- | Returns the smallest position, if any, in the 'File'.--smallestPos :: File -> Maybe Int-smallestPos = fmap (fst . fst) . IntMap.minViewWithKey . mapping---- | Convert the 'File' to a map from file positions (counting from 1)--- to meta information.--toMap :: File -> IntMap Aspects-toMap = mapping----------------------------------------------------------------------------- Compressed files---- | A compressed 'File', in which consecutive positions with the same--- 'Aspects' are stored together.--newtype CompressedFile =-  CompressedFile { ranges :: [(Range, Aspects)] }-  deriving (Eq, Show)---- | Invariant for compressed files.------ Note that these files are not required to be /maximally/--- compressed, because ranges are allowed to be empty, and the--- 'Aspects's in adjacent ranges are allowed to be equal.--compressedFileInvariant :: CompressedFile -> Bool-compressedFileInvariant (CompressedFile []) = True-compressedFileInvariant (CompressedFile f)  =-  all rangeInvariant rs &&-  all (not . empty) rs &&-  and (zipWith (<=) (map to $ init rs) (map from $ tail rs))-  where rs = map fst f---- | Compresses a file by merging consecutive positions with equal--- meta information into longer ranges.--compress :: File -> CompressedFile-compress f =-  CompressedFile $ map join $ groupBy' p (IntMap.toAscList $ mapping f)-  where-  p (pos1, m1) (pos2, m2) = pos2 == pos1 + 1 && m1 == m2-  join pms = ( Range { from = head ps, to = last ps + 1 }-             , head ms-             )-    where (ps, ms) = unzip pms---- | Decompresses a compressed file.--decompress :: CompressedFile -> File-decompress =-  File .-  IntMap.fromList .-  concat .-  map (\(r, m) -> [ (p, m) | p <- rangeToPositions r ]) .-  ranges---- | Clear any highlighting info for the given ranges. Used to make sure---   unsolved meta highlighting overrides error highlighting.-noHighlightingInRange :: Ranges -> CompressedFile -> CompressedFile-noHighlightingInRange rs (CompressedFile hs) =-    CompressedFile $ concatMap clear hs-  where-    clear (r, i) =-      case minus (Ranges [r]) rs of-        Ranges [] -> []-        Ranges rs -> [ (r, i) | r <- rs ]----------------------------------------------------------------------------- Operations that work directly with compressed files---- | @'singletonC' rs m@ is a file whose positions are those in @rs@,--- and in which every position is associated with @m@.--singletonC :: Ranges -> Aspects -> CompressedFile-singletonC (Ranges rs) m =-  CompressedFile [(r, m) | r <- rs, not (empty r)]---- | Like 'singletonR', but with a list of 'Ranges' instead of a--- single one.--severalC :: [Ranges] -> Aspects -> CompressedFile-severalC rss m = mconcat $ map (\rs -> singletonC rs m) rss---- | Merges compressed files.--mergeC :: CompressedFile -> CompressedFile -> CompressedFile-mergeC (CompressedFile f1) (CompressedFile f2) =-  CompressedFile (mrg f1 f2)-  where-  mrg []             f2             = f2-  mrg f1             []             = f1-  mrg (p1@(i1,_):f1) (p2@(i2,_):f2)-    | to i1 <= from i2 = p1 : mrg f1      (p2:f2)-    | to i2 <= from i1 = p2 : mrg (p1:f1) f2-    | to i1 <= to i2   = ps1 ++ mrg f1 (ps2 ++ f2)-    | otherwise        = ps1 ++ mrg (ps2 ++ f1) f2-      where (ps1, ps2) = fuse p1 p2--  -- Precondition: The ranges are overlapping.-  fuse (i1, m1) (i2, m2) =-    ( fix [ (Range { from = a, to = b }, ma)-          , (Range { from = b, to = c }, mergeAspects m1 m2)-          ]-    , fix [ (Range { from = c, to = d }, md)-          ]-    )-    where-    [(a, ma), (b, _), (c, _), (d, md)] =-      List.sortBy (compare `on` fst)-             [(from i1, m1), (to i1, m1), (from i2, m2), (to i2, m2)]-    fix = filter (not . empty . fst)--instance Semigroup CompressedFile where-  (<>) = mergeC--instance Monoid CompressedFile where-  mempty  = CompressedFile []-  mappend = (<>)---- | @splitAtC p f@ splits the compressed file @f@ into @(f1, f2)@,--- where all the positions in @f1@ are @< p@, and all the positions--- in @f2@ are @>= p@.--splitAtC :: Int -> CompressedFile ->-            (CompressedFile, CompressedFile)-splitAtC p f = (CompressedFile f1, CompressedFile f2)-  where-  (f1, f2) = split $ ranges f--  split [] = ([], [])-  split (rx@(r,x) : f)-    | p <= from r = ([], rx:f)-    | to r <= p   = (rx:f1, f2)-    | otherwise   = ([ (toP, x) ], (fromP, x) : f)-    where (f1, f2) = split f-          toP      = Range { from = from r, to = p    }-          fromP    = Range { from = p,      to = to r }--selectC :: P.Range -> CompressedFile -> CompressedFile-selectC r cf = cf'-  where-    empty         = (0,0)-    (from, to)    = fromMaybe empty (rangeToEndPoints r)-    (_, (cf', _)) = (second (splitAtC to)) . splitAtC from $ cf-+-- NFData instances --- | Returns the smallest position, if any, in the 'CompressedFile'.+instance NFData Aspect+instance NFData NameKind+instance NFData OtherAspect+instance NFData DefinitionSite -smallestPosC :: CompressedFile -> Maybe Int-smallestPosC (CompressedFile [])           = Nothing-smallestPosC (CompressedFile ((r, _) : _)) = Just (from r)+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

@@ -7,25 +7,41 @@   , Ranges(..)   , rangesInvariant   , overlapping+  , overlappings   , empty   , rangeToPositions   , rangesToPositions   , rToR-  , rangeToEndPoints+  , 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 }+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@@ -34,7 +50,7 @@ -- | Zero or more consecutive and separated ranges.  newtype Ranges = Ranges [Range]-  deriving (Eq, Show)+  deriving (Eq, Show, NFData)  -- | The 'Ranges' invariant. @@ -51,13 +67,15 @@ -- The ranges are assumed to be well-formed.  overlapping :: Range -> Range -> Bool-overlapping r1 r2 = not $-  to r1 <= from r2 || to r2 <= from r1+overlapping r1 r2 = (not $ r1 `isLeftOf` r2) && (not $ r2 `isLeftOf` r1) --- | 'True' iff the range is empty.+isLeftOf :: Range -> Range -> Bool+isLeftOf r1 r2 = to r1 <= from r2 -empty :: Range -> Bool-empty r = to r <= from r+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@@ -82,12 +100,15 @@                    }) =     Range { from = fromIntegral pos1, to = fromIntegral pos2 } -rangeToEndPoints :: P.Range -> Maybe (Int,Int)-rangeToEndPoints r =+-- | Converts a 'P.Range', seen as a continuous range, to a 'Range'.++rangeToRange :: P.Range -> Range+rangeToRange r =   case P.rangeToInterval r of-          Nothing -> Nothing-          Just i  -> Just ( fromIntegral $ P.posPos $ P.iStart i-                          , fromIntegral $ P.posPos $ P.iEnd i)+    Nothing -> Range { from = 0, to = 0 }+    Just i  -> Range { from = fromIntegral $ P.posPos $ P.iStart i+                     , to   = fromIntegral $ P.posPos $ P.iEnd i+                     }  ------------------------------------------------------------------------ -- Operations@@ -104,7 +125,7 @@   m []     _      = []   m xs     []     = xs   m (x:xs) (y:ys)-    | empty y         = m (x:xs) 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 } :

src/full/Agda/Interaction/Highlighting/Vim.hs view

@@ -6,6 +6,7 @@ import Data.Function ( on ) import qualified Data.List as List import qualified Data.Map as Map+import Data.Maybe  import System.FilePath @@ -17,6 +18,7 @@  import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Tuple+import Agda.Utils.Pretty  vimFile :: FilePath -> FilePath vimFile file =@@ -39,9 +41,13 @@ keyword cat ws  = "syn keyword " ++ unwords (cat : ws)  match :: String -> [String] -> String-match _ [] = ""-match cat ws    = "syn match " ++ cat ++ " \"" ++-                    concat (List.intersperse "\\|" $ map (wordBounded . escape) ws) ++ "\""+match _   [] = ""+match cat ws =+  "syn match "+    ++ cat+    ++ " \""+    ++ List.intercalate "\\|" (map (wordBounded . escape) ws)+    ++ "\""  matches :: [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] matches cons icons defs idefs flds iflds =@@ -53,8 +59,6 @@         icons' = foo "agdaInfixConstructor" $ classify length icons         defs'  = foo "agdaFunction"         $ classify length defs         idefs' = foo "agdaInfixFunction"    $ classify length idefs-        flds'  = foo "agdaProjection"       $ classify length flds-        iflds' = foo "agdaInfixProjection"  $ classify length iflds          classify f = List.groupBy ((==) `on` f)                      . List.sortBy (compare `on` f)@@ -65,21 +69,21 @@ toVim :: NamesInScope -> String toVim ns = unlines $ matches mcons micons mdefs midefs mflds miflds     where-        cons = [ x | (x, def:_) <- Map.toList ns, anameKind def == ConName ]-        defs = [ x | (x, def:_) <- Map.toList ns, isDefName (anameKind def)]-        flds = [ x | (x, fld:_) <- Map.toList ns, anameKind fld == FldName ]+        cons = [ x | (x, con:_) <- Map.toList ns, isJust $ isConName $ anameKind con ]+        defs = [ x | (x, def:_) <- Map.toList ns, isDefName (anameKind def) ]+        flds = [ x | (x, fld:_) <- Map.toList ns, anameKind fld == FldName  ] -        mcons = map show cons-        mdefs = map show defs-        mflds = map show flds+        mcons = map prettyShow cons+        mdefs = map prettyShow defs+        mflds = map prettyShow flds          micons = concatMap parts cons         midefs = concatMap parts defs         miflds = concatMap parts flds -        parts (NoName _ _)    = []-        parts (Name _ _ [_])  = []-        parts (Name _ _ ps)   = [ rawNameToString x | Id x <- ps ]+        parts n+          | isOperator n = map rawNameToString $ nameStringParts n+          | otherwise    = []  generateVimFile :: FilePath -> TCM () generateVimFile file = do

src/full/Agda/Interaction/Imports.hs view

@@ -3,1208 +3,1220 @@ {-| This module deals with finding imported modules and loading their     interface files. -}-module Agda.Interaction.Imports where--import Prelude hiding (null)--import Control.Arrow-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Maybe-import qualified Control.Exception as E--import qualified Data.Map as Map-import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Maybe-import Data.Monoid (mempty, mappend)-import Data.Map (Map)-import qualified Data.HashMap.Strict as HMap-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T--import System.Directory (doesFileExist, getModificationTime, removeFile)-import System.FilePath ((</>))--import Agda.Benchmarking--import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Abstract.Name-import Agda.Syntax.Common-import Agda.Syntax.Parser-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base-import Agda.Syntax.Translation.ConcreteToAbstract--import Agda.TypeChecking.Errors-import Agda.TypeChecking.Warnings-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Rewriting.Confluence ( checkConfluenceOfRules )-import Agda.TypeChecking.MetaVars ( openMetasToPostulates )-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Serialise-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Pretty as P-import Agda.TypeChecking.DeadCode-import qualified Agda.TypeChecking.Monad.Benchmark as Bench--import Agda.TheTypeChecker--import Agda.Interaction.BasicOps (getGoals, showGoals)-import Agda.Interaction.FindFile-import Agda.Interaction.Highlighting.Generate-import Agda.Interaction.Highlighting.Precise  ( compress )-import Agda.Interaction.Highlighting.Vim-import Agda.Interaction.Options-import qualified Agda.Interaction.Options.Lenses as Lens-import Agda.Interaction.Response-  (RemoveTokenBasedHighlighting(KeepHighlighting))--import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.FileName-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.IO.Binary-import Agda.Utils.Pretty hiding (Mode)-import Agda.Utils.Hash-import qualified Agda.Utils.Trie as Trie--import Agda.Utils.Impossible---- | Some information about the source code.--data SourceInfo = SourceInfo-  { siSource     :: Text                  -- ^ Source code.-  , siFileType   :: FileType              -- ^ Source file type-  , siModule     :: C.Module              -- ^ The parsed module.-  , siModuleName :: C.TopLevelModuleName  -- ^ The top-level module name.-  }---- | Computes a 'SourceInfo' record for the given file.--sourceInfo :: SourceFile -> TCM SourceInfo-sourceInfo (SourceFile f) = Bench.billTo [Bench.Parsing] $ do-  source                <- runPM $ readFilePM f-  (parsedMod, fileType) <- runPM $-                           parseFile moduleParser f $ T.unpack source-  moduleName            <- moduleName f parsedMod-  return SourceInfo-    { siSource     = source-    , siFileType   = fileType-    , siModule     = parsedMod-    , siModuleName = moduleName-    }---- | Is the aim to type-check the top-level module, or only to--- scope-check it?--data Mode-  = ScopeCheck-  | TypeCheck-  deriving (Eq, Show)---- | Are we loading the interface for the user-loaded file---   or for an import?-data MainInterface-  = MainInterface Mode -- ^ For the main file.-                       ---                       --   In this case state changes inflicted by-                       --   'createInterface' are preserved.-  | NotMainInterface   -- ^ For an imported file.-                       ---                       --   In this case state changes inflicted by-                       --   'createInterface' are not preserved.-  deriving (Eq, Show)---- | Should state changes inflicted by 'createInterface' be preserved?--includeStateChanges :: MainInterface -> Bool-includeStateChanges (MainInterface _) = True-includeStateChanges NotMainInterface  = False---- | Merge an interface into the current proof state.-mergeInterface :: Interface -> TCM ()-mergeInterface i = do-    let sig     = iSignature i-        builtin = Map.toList $ iBuiltin i-        prim    = [ x | (_,Prim x) <- builtin ]-        bi      = Map.fromList [ (x,Builtin t) | (x,Builtin t) <- builtin ]-        warns   = iWarnings i-    bs <- getsTC stBuiltinThings-    reportSLn "import.iface.merge" 10 "Merging interface"-    reportSLn "import.iface.merge" 20 $-      "  Current builtins " ++ show (Map.keys bs) ++ "\n" ++-      "  New builtins     " ++ show (Map.keys bi)-    let check b = case (b1, b2) of-            (Builtin x, Builtin y)-              | x == y    -> return ()-              | otherwise -> typeError $ DuplicateBuiltinBinding b x y-            _ -> __IMPOSSIBLE__-          where-            Just b1 = Map.lookup b bs-            Just b2 = Map.lookup b bi-    mapM_ check (map fst $ Map.toList $ Map.intersection bs bi)-    addImportedThings sig bi (iPatternSyns i) (iDisplayForms i) (iUserWarnings i) (iPartialDefs i) warns-    reportSLn "import.iface.merge" 20 $-      "  Rebinding primitives " ++ show prim-    mapM_ rebind prim-    whenM (optConfluenceCheck <$> pragmaOptions) $ do-      reportSLn "import.iface.confluence" 20 $ "  Checking confluence of imported rewrite rules"-      checkConfluenceOfRules $ concat $ HMap.elems $ sig ^. sigRewriteRules-    where-        rebind (x, q) = do-            PrimImpl _ pf <- lookupPrimitiveFunction x-            stImportedBuiltins `modifyTCLens` Map.insert x (Prim pf{ primFunName = q })--addImportedThings-  :: Signature-  -> BuiltinThings PrimFun-  -> A.PatternSynDefns-  -> DisplayForms-  -> Map A.QName String    -- ^ Imported user warnings-  -> Set QName             -- ^ Name of imported definitions which are partial-  -> [TCWarning]-  -> TCM ()-addImportedThings isig ibuiltin patsyns display userwarn partialdefs warnings = do-  stImports              `modifyTCLens` \ imp -> unionSignatures [imp, isig]-  stImportedBuiltins     `modifyTCLens` \ imp -> Map.union 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-  stTCWarnings           `modifyTCLens` \ imp -> List.union imp warnings-  addImportedInstances isig---- | Scope checks the given module. A proper version of the module--- name (with correct definition sites) is returned.--scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)-scopeCheckImport x = do-    reportSLn "import.scope" 5 $ "Scope checking " ++ prettyShow x-    verboseS "import.scope" 10 $ do-      visited <- Map.keys <$> getVisitedModules-      reportSLn "import.scope" 10 $-        "  visited: " ++ List.intercalate ", " (map prettyShow visited)-    -- Since scopeCheckImport is called from the scope checker,-    -- we need to reimburse her account.-    i <- Bench.billTo [] $ getInterface x-    addImport x--    -- If that interface was supposed to raise a warning on import, do so.-    whenJust (iImportWarning i) $ warning . UserWarning--    -- let s = publicModules $ iInsideScope i-    let s = iScope i-    return (iModuleName i `withRangesOfQ` mnameToConcrete x, s)--data MaybeWarnings' a = NoWarnings | SomeWarnings a-  deriving (Show, Functor, Foldable, Traversable)-type MaybeWarnings = MaybeWarnings' [TCWarning]--applyFlagsToMaybeWarnings :: MaybeWarnings -> TCM MaybeWarnings-applyFlagsToMaybeWarnings mw = do-  w' <- traverse applyFlagsToTCWarnings mw-  return $ if null w' then NoWarnings else w'--instance Null a => Null (MaybeWarnings' a) where-  empty = NoWarnings-  null mws = case mws of-    NoWarnings      -> True-    SomeWarnings ws -> null ws--hasWarnings :: MaybeWarnings -> Bool-hasWarnings = not . null---- | 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 (unless the 'MainInterface' is @'MainInterface'--- 'ScopeCheck'@).--alreadyVisited :: C.TopLevelModuleName ->-                  MainInterface ->-                  PragmaOptions ->-                  TCM (Interface, MaybeWarnings) ->-                  TCM (Interface, MaybeWarnings)-alreadyVisited x isMain currentOptions getIface = do-    mm <- getVisitedModule x-    case mm of-        -- A module with warnings should never be allowed to be-        -- imported from another module.-        Just mi | not (miWarnings mi) -> do-          reportSLn "import.visit" 10 $ "  Already visited " ++ prettyShow x-          let i = miInterface mi-          -- Check that imported options are compatible with current ones,-          -- but give primitive modules a pass-          optsCompat <- if miPrimitive mi then return True else-            ifM (asksTC envCheckOptionConsistency)-            {-then-} (checkOptionsCompatible currentOptions (iOptionsUsed i)-                                             (iModuleName i))-            {-else-} (return True)-          if optsCompat then return (i , NoWarnings) else do-            wt <- getMaybeWarnings' isMain ErrorWarnings-            return (i, wt)-        _ -> do-          reportSLn "import.visit" 5 $ "  Getting interface for " ++ prettyShow x-          r@(i, wt) <- getIface-          reportSLn "import.visit" 5 $ "  Now we've looked at " ++ prettyShow x-          unless (isMain == MainInterface ScopeCheck) $-            visitModule ModuleInfo-              { miInterface  = i-              , miWarnings   = hasWarnings wt-              , miPrimitive  = False -- will be updated later for primitive modules-              }-          return r---- | 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.------   First, the primitive modules are imported.---   Then, @getInterface'@ is called to do the main work.------   If the 'Mode' is 'ScopeCheck', then type-checking is not---   performed, only scope-checking. (This may include type-checking---   of imported modules.) In this case the generated, partial---   interface is not stored in the state ('stDecodedModules'). Note,---   however, that if the file has already been type-checked, then a---   complete interface is returned.--typeCheckMain-  :: SourceFile-     -- ^ The path to the file.-  -> Mode-     -- ^ Should the file be type-checked, or only scope-checked?-  -> SourceInfo-     -- ^ Information about the source code.-  -> TCM (Interface, MaybeWarnings)-typeCheckMain f mode si = do-  -- liftIO $ putStrLn $ "This is typeCheckMain " ++ prettyShow f-  -- liftIO . putStrLn . show =<< getVerbosity-  reportSLn "import.main" 10 "Importing the primitive modules."-  libdir <- liftIO defaultLibDir-  let libdirPrim = libdir </> "prim"-  reportSLn "import.main" 20 $ "Library dir = " ++ show libdir-  -- Turn off import-chasing messages.-  -- We have to modify the persistent verbosity setting, since-  -- getInterface resets the current verbosity settings to the persistent ones.-  bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do-    Lens.modifyPersistentVerbosity (Trie.delete [])  -- set root verbosity to 0--    -- We don't want to generate highlighting information for Agda.Primitive.-    withHighlightingLevel None $ withoutOptionsChecking $-      forM_ (Set.map (libdirPrim </>) Lens.primitiveModules) $ \f -> do-        let file = SourceFile $ mkAbsolute f-        si <- sourceInfo file-        checkModuleName' (siModuleName si) file-        _ <- getInterface_ (siModuleName si) (Just si)-        -- record that the just visited module is primitive-        mapVisitedModule (siModuleName si) (\ m -> m { miPrimitive = True })--  reportSLn "import.main" 10 $ "Done importing the primitive modules."--  -- Now do the type checking via getInterface'.-  checkModuleName' (siModuleName si) f-  getInterface' (siModuleName si) (MainInterface mode) (Just si)-  where-  checkModuleName' m f =-    -- Andreas, 2016-07-11, issue 2092-    -- The error range should be set to the file with the wrong module name-    -- not the importing one (which would be the default).-    (if null r then id else traceCall (SetRange r)) $-      checkModuleName m f Nothing-    where-    r = getRange m---- | Tries to return the interface associated to the given (imported) module.---   The time stamp of the relevant interface file is also returned.---   Calls itself recursively for the imports of the given module.---   May type check the module.---   An error is raised if a warning is encountered.------   Do not use this for the main file, use 'typeCheckMain' instead.--getInterface :: ModuleName -> TCM Interface-getInterface m = getInterface_ (toTopLevelModuleName m) Nothing---- | See 'getInterface'.--getInterface_-  :: C.TopLevelModuleName-  -> Maybe SourceInfo-     -- ^ Optional information about the source code.-  -> TCM Interface-getInterface_ x msi = do-  (i, wt) <- getInterface' x NotMainInterface msi-  case wt of-    SomeWarnings w  -> tcWarningsToError (filter (notIM . tcWarning) w)-    NoWarnings      -> return i-   -- filter out unsolved interaction points for imported module so-   -- that we get the right error message (see test case Fail/Issue1296)-   where notIM UnsolvedInteractionMetas{} = False-         notIM _                          = True----- | A more precise variant of 'getInterface'. If warnings are--- encountered then they are returned instead of being turned into--- errors.--getInterface'-  :: C.TopLevelModuleName-  -> MainInterface-  -> Maybe SourceInfo-     -- ^ Optional information about the source code.-  -> TCM (Interface, MaybeWarnings)-getInterface' x isMain msi =-  withIncreasedModuleNestingLevel $-    -- Preserve the pragma options unless we are checking the main-    -- interface.-    bracket_ (useTC stPragmaOptions)-             (unless (includeStateChanges isMain) . (stPragmaOptions `setTCLens`)) $ do-     -- We remember but reset the pragma options locally-     -- For the main interface, we also remember the pragmas from the file-     when (includeStateChanges isMain) $ do-       pragmas <- concreteOptionsToOptionPragmas-                    (fst $ maybe __IMPOSSIBLE__ siModule msi)-       mapM_ setOptionsFromPragma pragmas-     currentOptions <- useTC stPragmaOptions-     -- Now reset the options-     setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC--     alreadyVisited x isMain currentOptions $ addImportCycleCheck x $ do-      file <- findFile x  -- requires source to exist--      reportSLn "import.iface" 10 $ "  Check for cycle"-      checkForImportCycle--      uptodate <- Bench.billTo [Bench.Import] $ do-        ignore <- (ignoreInterfaces `and2M`-                    (not <$> Lens.isBuiltinModule (filePath $ srcFilePath file)))-                  `or2M` ignoreAllInterfaces-        cached <- runMaybeT $ isCached x file-          -- If it's cached ignoreInterfaces has no effect;-          -- to avoid typechecking a file more than once.-        sourceH <- case msi of-                     Nothing -> liftIO $ hashTextFile (srcFilePath file)-                     Just si -> return $ hashText (siSource si)-        ifaceH  <- case cached of-            Nothing -> do-              mifile <- toIFile file-              fmap fst <$> getInterfaceFileHashes mifile-            Just i  -> return $ Just $ iSourceHash i-        let unchanged = Just sourceH == ifaceH-        return $ unchanged && (not ignore || isJust cached)--      reportSLn "import.iface" 5 $-        "  " ++ prettyShow x ++ " is " ++-        (if uptodate then "" else "not ") ++ "up-to-date."--      (stateChangesIncluded, (i, wt)) <- do-        -- -- 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.-        let maySkip = True--        if uptodate && maySkip-          then getStoredInterface x file isMain msi-          else typeCheck          x file isMain msi--      -- Ensure that the given module name matches the one in the file.-      let topLevelName = toTopLevelModuleName $ iModuleName i-      unless (topLevelName == x) $-        -- Andreas, 2014-03-27 This check is now done in the scope checker.-        -- checkModuleName topLevelName file-        typeError $ OverlappingProjects (srcFilePath file) topLevelName x--      visited <- isVisited x-      reportSLn "import.iface" 5 $ if visited then "  We've been here. Don't merge."-                                   else "  New module. Let's check it out."--      -- Check that imported module options are consistent with-      -- current options (issue #2487)-      -- compute updated warnings if needed-      wt' <- ifM (not <$> asksTC envCheckOptionConsistency)-                 {- then -} (return wt) {- else -} $ do-        optComp <- checkOptionsCompatible currentOptions (iOptionsUsed i) (iModuleName i)-        -- we might have aquired some more warnings when consistency checking-        if optComp then return wt else getMaybeWarnings' isMain ErrorWarnings--      unless (visited || stateChangesIncluded) $ do-        mergeInterface i-        Bench.billTo [Bench.Highlighting] $-          ifTopLevelAndHighlightingLevelIs NonInteractive $-            highlightFromInterface i file--      stCurrentModule `setTCLens` Just (iModuleName i)--      -- Interfaces are not stored if we are only scope-checking, or-      -- if any warnings were encountered.-      case (isMain, wt') of-        (MainInterface ScopeCheck, _) -> return ()-        (_, SomeWarnings w)           -> return ()-        _                             -> storeDecodedModule i--      reportS "warning.import" 10-        [ "module: " ++ show (C.moduleNameParts x)-        , "WarningOnImport: " ++ show (iImportWarning i)-        ]-      return (i, wt')---- | Check if the options used for checking an imported module are---   compatible with the current options. Raises Non-fatal errors if---   not.-checkOptionsCompatible :: PragmaOptions -> PragmaOptions -> ModuleName -> TCM Bool-checkOptionsCompatible current imported importedModule = flip execStateT True $ do-  reportSDoc "import.iface.options" 5 $ P.nest 2 $ "current options  =" P.<+> showOptions current-  reportSDoc "import.iface.options" 5 $ P.nest 2 $ "imported options =" P.<+> showOptions imported-  forM_ coinfectiveOptions $ \ (opt, optName) -> do-    unless (opt current `implies` opt imported) $ do-      put False-      warning (CoInfectiveImport optName importedModule)-  forM_ infectiveOptions $ \ (opt, optName) -> do-    unless (opt imported `implies` opt current) $ do-      put False-      warning (InfectiveImport optName importedModule)-  where-    implies :: Bool -> Bool -> Bool-    p `implies` q = p <= q--    showOptions opts = P.prettyList (map (\ (o, n) -> (P.text n <> ": ") P.<+> (P.pretty $ o opts))-                                 (coinfectiveOptions ++ infectiveOptions))---- | Check whether interface file exists and is in cache---   in the correct version (as testified by the interface file hash).--isCached-  :: C.TopLevelModuleName-     -- ^ Module name of file we process.-  -> SourceFile-     -- ^ File we process.-  -> MaybeT TCM Interface--isCached x file = do-  ifile <- MaybeT $ findInterfaceFile' file--  -- Check that we have cached the module.-  mi <- MaybeT $ getDecodedModule x--  -- Check that the interface file exists and return its hash.-  h  <- MaybeT $ fmap snd <$> getInterfaceFileHashes' ifile--  -- Make sure the hashes match.-  guard $ iFullHash mi == h--  return mi---- | Try to get the interface from interface file or cache.--getStoredInterface-  :: C.TopLevelModuleName-     -- ^ Module name of file we process.-  -> SourceFile-     -- ^ File we process.-  -> MainInterface-  -> Maybe SourceInfo-     -- ^ Optional information about the source code.-  -> TCM (Bool, (Interface, MaybeWarnings))-     -- ^ @Bool@ is: do we have to merge the interface?-getStoredInterface x file isMain msi = do-  let fp = filePath $ srcFilePath file-  -- If something goes wrong (interface outdated etc.)-  -- we revert to fresh type checking.-  let fallback = typeCheck x file isMain msi--  -- Examine the hash of the interface file. If it is different from the-  -- stored version (in stDecodedModules), or if there is no stored version,-  -- read and decode it. Otherwise use the stored version.-  ifile <- toIFile file-  let ifp = filePath ifile-  h <- fmap snd <$> getInterfaceFileHashes ifile-  mm <- getDecodedModule x-  (cached, mi) <- Bench.billTo [Bench.Deserialization] $ case mm of-    Just mi ->-      if Just (iFullHash mi) /= h-      then do-        dropDecodedModule x-        reportSLn "import.iface" 50 $ "  cached hash = " ++ show (iFullHash mi)-        reportSLn "import.iface" 50 $ "  stored hash = " ++ show h-        reportSLn "import.iface" 5 $ "  file is newer, re-reading " ++ ifp-        (False,) <$> readInterface ifile-      else do-        reportSLn "import.iface" 5 $ "  using stored version of " ++ ifp-        return (True, Just mi)-    Nothing -> do-      reportSLn "import.iface" 5 $ "  no stored version, reading " ++ ifp-      (False,) <$> readInterface ifile--  -- Check that it's the right version-  case mi of-    Nothing       -> do-      reportSLn "import.iface" 5 "  bad interface, re-type checking"-      fallback-    Just i        -> do-      reportSLn "import.iface" 5 $ "  imports: " ++ show (iImportedModules i)--      -- We set the pragma options of the skipped file here, so that-      -- we can check that they are compatible with those of the-      -- imported modules. Also, if the top-level file is skipped we-      -- want the pragmas to apply to interactive commands in the UI.-      mapM_ setOptionsFromPragma (iPragmaOptions i)--      -- Check that options that matter haven't changed compared to-      -- current options (issue #2487)-      optionsChanged <-ifM ((not <$> asksTC envCheckOptionConsistency) `or2M`-                            Lens.isBuiltinModule fp)-                       {-then-} (return False) {-else-} $ do-        currentOptions <- useTC stPragmaOptions-        let disagreements =-              [ optName | (opt, optName) <- restartOptions,-                          opt currentOptions /= opt (iOptionsUsed i) ]-        if null disagreements then return False else do-          reportSLn "import.iface.options" 4 $ concat-            [ "  Changes in the following options in "-            , prettyShow fp-            , ", re-typechecking: "-            , prettyShow disagreements-            ]-          return True--      if optionsChanged then fallback else do--        hs <- map iFullHash <$> mapM getInterface (map fst $ iImportedModules i)--        -- If any of the imports are newer we need to retype check-        if hs /= map snd (iImportedModules i)-          then fallback-          else do-            unless cached $ do-              chaseMsg "Loading " x $ Just ifp-              -- print imported warnings-              let ws = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (iWarnings i)-              unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws--            return (False, (i, NoWarnings))---- | Run the type checker on a file and create an interface.------   Mostly, this function calls 'createInterface'.---   But if it is not the main module we check,---   we do it in a fresh state, suitably initialize,---   in order to forget some state changes after successful type checking.--typeCheck-  :: C.TopLevelModuleName-     -- ^ Module name of file we process.-  -> SourceFile-     -- ^ File we process.-  -> MainInterface-  -> Maybe SourceInfo-     -- ^ Optional information about the source code.-  -> TCM (Bool, (Interface, MaybeWarnings))-     -- ^ @Bool@ is: do we have to merge the interface?-typeCheck x file isMain msi = do-  let fp = filePath $ srcFilePath file-  unless (includeStateChanges isMain) cleanCachedLog-  let checkMsg = case isMain of-                   MainInterface ScopeCheck -> "Reading "-                   _                        -> "Checking"-      withMsgs = bracket_-       (chaseMsg checkMsg x $ Just fp)-       (const $ do ws <- getAllWarnings AllWarnings-                   let classified = classifyWarnings ws-                   let wa' = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (tcWarnings classified)-                   unless (null wa') $-                     reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> wa'-                   when (null (nonFatalErrors classified)) $ chaseMsg "Finished" x Nothing)--  -- Do the type checking.--  case isMain of-    MainInterface _ -> do-      r <- withMsgs $ createInterface file x isMain msi-      return (True, r)--    NotMainInterface -> do-      ms          <- getImportPath-      nesting     <- asksTC envModuleNestingLevel-      range       <- asksTC envRange-      call        <- asksTC envCall-      mf          <- useTC stModuleToSource-      vs          <- getVisitedModules-      ds          <- getDecodedModules-      opts        <- stPersistentOptions . stPersistentState <$> getTC-      isig        <- useTC stImports-      ibuiltin    <- useTC stImportedBuiltins-      display     <- useTC stImportsDisplayForms-      userwarn    <- useTC stImportedUserWarnings-      partialdefs <- useTC stImportedPartialDefs-      ipatsyns <- getPatternSynImports-      ho       <- getInteractionOutputCallback-      -- 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.-      r <- 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 { envModuleNestingLevel = nesting-                              -- Andreas, 2014-08-18:-                              -- Preserve the range of import statement-                              -- for reporting termination errors in-                              -- imported modules:-                            , envRange              = range-                            , envCall               = call-                            }) $ do-               setDecodedModules ds-               setCommandLineOptions opts-               setInteractionOutputCallback ho-               stModuleToSource `setTCLens` mf-               setVisitedModules vs-               addImportedThings isig ibuiltin ipatsyns display userwarn partialdefs []--               r  <- withMsgs $ createInterface file x isMain msi-               mf <- useTC stModuleToSource-               ds <- getDecodedModules-               return (r, do-                  stModuleToSource `setTCLens` mf-                  setDecodedModules ds-                  case r of-                    (i, NoWarnings) -> storeDecodedModule i-                    _               -> return ()-                  )--      case r of-          Left err          -> throwError err-          Right (r, update) -> do-            update-            case r of-              (_, NoWarnings) ->-                -- We skip the file which has just been type-checked to-                -- be able to forget some of the local state from-                -- checking the module.-                -- Note that this doesn't actually read the interface-                -- file, only the cached interface. (This comment is not-                -- correct, see-                -- test/Fail/customised/NestedProjectRoots.err.)-                getStoredInterface x file isMain msi-              _ -> return (False, r)---- | Formats and outputs the "Checking", "Finished" and "Loading " messages.--chaseMsg-  :: String               -- ^ The prefix, like @Checking@, @Finished@, @Loading @.-  -> C.TopLevelModuleName -- ^ The module name.-  -> Maybe String         -- ^ Optionally: the file name.-  -> TCM ()-chaseMsg kind x file = do-  indentation <- (`replicate` ' ') <$> asksTC envModuleNestingLevel-  let maybeFile = caseMaybe file "." $ \ f -> " (" ++ f ++ ")."-      vLvl | kind == "Checking" = 1-           | otherwise          = 2-  reportSLn "import.chase" vLvl $ concat-    [ indentation, kind, " ", prettyShow x, maybeFile ]---- | Print the highlighting information contained in the given interface.--highlightFromInterface-  :: Interface-  -> SourceFile-     -- ^ The corresponding file.-  -> TCM ()-highlightFromInterface i file = do-  reportSLn "import.iface" 5 $-    "Generating syntax info for " ++ filePath (srcFilePath file) ++-    " (read from interface)."-  printHighlightingInfo KeepHighlighting (iHighlighting i)---- | Read interface file corresponding to a module.--readInterface :: AbsolutePath -> TCM (Maybe Interface)-readInterface file = runMaybeT $ do-  ifile <- MaybeT $ liftIO $ mkInterfaceFile file-  MaybeT $ readInterface' ifile--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 e = case e of-      IOException _ _ e -> do-        reportSLn "" 0 $ "IO exception: " ++ show e-        return Nothing   -- Work-around for file locking bug.-                         -- TODO: What does this refer to? Please-                         -- document.-      _ -> throwError e---- | Writes the given interface to the given file.------ The written interface is decoded and returned.--writeInterface :: AbsolutePath -> Interface -> TCM Interface-writeInterface file i = let fp = filePath file in do-    reportSLn "import.iface.write" 5  $-      "Writing interface file " ++ fp ++ "."-    -- Andreas, 2015-07-13-    -- After QName memoization (AIM XXI), scope serialization might be cheap enough.-    -- -- Andreas, Makoto, 2014-10-18 AIM XX:-    -- -- iInsideScope is bloating the interface files, so we do not serialize it?-    -- i <- return $-    --   i { iInsideScope  = emptyScopeInfo-    --     }-    -- Andreas, 2016-02-02 this causes issue #1804, so don't do it:-    -- i <- return $-    --   i { iInsideScope  = removePrivates $ iInsideScope i-    --     }-    reportSLn "import.iface.write" 50 $-      "Writing interface file with hash" ++ show (iFullHash i) ++ "."-    i' <- encodeFile fp i-    reportSLn "import.iface.write" 5 "Wrote interface file."-    i <--#if __GLASGOW_HASKELL__ >= 804-      Bench.billTo [Bench.Deserialization] (decode i')-#else-      return (Just i)-#endif-    case i of-      Just i  -> return i-      Nothing -> __IMPOSSIBLE__-  `catchError` \e -> do-    reportSLn "" 1 $-      "Failed to write interface " ++ fp ++ "."-    liftIO $-      whenM (doesFileExist fp) $ removeFile fp-    throwError e--removePrivates :: ScopeInfo -> ScopeInfo-removePrivates = over scopeModules $ fmap restrictPrivate--concreteOptionsToOptionPragmas :: [C.Pragma] -> TCM [OptionsPragma]-concreteOptionsToOptionPragmas p = do-  pragmas <- concat <$> concreteToAbstract_ p-  -- identity for top-level pragmas at the moment-  let getOptions (A.OptionsPragma opts) = Just opts-      getOptions _                      = Nothing-  return $ mapMaybe getOptions pragmas---- | Tries to type check a module and write out its interface. The--- function only writes out an interface file if it does not encounter--- any warnings.------ If appropriate this function writes out syntax highlighting--- information.--createInterface-  :: SourceFile            -- ^ The file to type check.-  -> C.TopLevelModuleName  -- ^ The expected module name.-  -> MainInterface         -- ^ Are we dealing with the main module?-  -> Maybe SourceInfo      -- ^ Optional information about the source code.-  -> TCM (Interface, MaybeWarnings)-createInterface file mname isMain msi =-  Bench.billTo [Bench.TopModule mname] $-  localTC (\e -> e { envCurrentPath = Just (srcFilePath file) }) $ do--    reportSLn "import.iface.create" 5 $-      "Creating interface for " ++ prettyShow mname ++ "."-    verboseS "import.iface.create" 10 $ do-      visited <- Map.keys <$> getVisitedModules-      reportSLn "import.iface.create" 10 $-        "  visited: " ++ List.intercalate ", " (map prettyShow visited)--    (source, fileType, (pragmas, top)) <- do-      si <- case msi of-        Nothing -> sourceInfo file-        Just si -> return si-      case si of-        SourceInfo {..} -> return (siSource, siFileType, siModule)--    modFile       <- useTC stModuleToSource-    fileTokenInfo <- Bench.billTo [Bench.Highlighting] $-                       generateTokenInfoFromSource-                         (srcFilePath file) (T.unpack source)-    stTokens `setTCLens` fileTokenInfo--    options <- concreteOptionsToOptionPragmas pragmas-    mapM_ setOptionsFromPragma options---    -- Scope checking.-    reportSLn "import.iface.create" 7 "Starting scope checking."-    topLevel <- Bench.billTo [Bench.Scoping] $-      concreteToAbstract_ (TopLevel (srcFilePath file) mname top)-    reportSLn "import.iface.create" 7 "Finished scope checking."--    let ds    = topLevelDecls topLevel-        scope = topLevelScope topLevel--    -- Highlighting from scope checker.-    reportSLn "import.iface.create" 7 "Starting highlighting from scope."-    Bench.billTo [Bench.Highlighting] $ do-      -- Generate and print approximate syntax highlighting info.-      ifTopLevelAndHighlightingLevelIs NonInteractive $-        printHighlightingInfo KeepHighlighting fileTokenInfo-      let onlyScope = isMain == MainInterface ScopeCheck-      ifTopLevelAndHighlightingLevelIsOr NonInteractive onlyScope $-        mapM_ (\ d -> generateAndPrintSyntaxInfo d Partial onlyScope) ds-    reportSLn "import.iface.create" 7 "Finished highlighting from scope."---    -- Type checking.--    -- Now that all the options are in we can check if caching should-    -- be on.-    activateLoadedFileCache--    -- invalidate cache if pragmas change, TODO move-    cachingStarts-    opts <- useTC stPragmaOptions-    me <- readFromCachedLog-    case me of-      Just (Pragmas opts', _) | opts == opts'-        -> return ()-      _ -> do-        reportSLn "cache" 10 $ "pragma changed: " ++ show (isJust me)-        cleanCachedLog-    writeToCurrentLog $ Pragmas opts--    case isMain of-      MainInterface ScopeCheck -> do-        reportSLn "import.iface.create" 7 "Skipping type checking."-        cacheCurrentLog-      _ -> do-        reportSLn "import.iface.create" 7 "Starting type checking."-        Bench.billTo [Bench.Typing] $ mapM_ checkDeclCached ds `finally_` cacheCurrentLog-        reportSLn "import.iface.create" 7 "Finished type checking."--    -- Ulf, 2013-11-09: Since we're rethrowing the error, leave it up to the-    -- code that handles that error to reset the state.-    -- Ulf, 2013-11-13: Errors are now caught and highlighted in InteractionTop.-    -- catchError_ (checkDecls ds) $ \e -> do-    --   ifTopLevelAndHighlightingLevelIs NonInteractive $-    --     printErrorInfo e-    --   throwError e--    unfreezeMetas--    -- Profiling: Count number of metas.-    verboseS "profile.metas" 10 $ do-      MetaId n <- fresh-      tickN "metas" (fromIntegral n)--    -- Highlighting from type checker.-    reportSLn "import.iface.create" 7 "Starting highlighting from type info."-    Bench.billTo [Bench.Highlighting] $ do--      -- Move any remaining token highlighting to stSyntaxInfo.-      toks <- useTC stTokens-      ifTopLevelAndHighlightingLevelIs NonInteractive $-        printHighlightingInfo KeepHighlighting toks-      stTokens `setTCLens` mempty--      -- Grabbing warnings and unsolved metas to highlight them-      warnings <- getAllWarnings AllWarnings-      unless (null warnings) $ reportSDoc "import.iface.create" 20 $-        "collected warnings: " <> prettyTCM warnings-      unsolved <- getAllUnsolved-      unless (null unsolved) $ reportSDoc "import.iface.create" 20 $-        "collected unsolved: " <> prettyTCM unsolved-      let warningInfo = compress $ foldMap warningHighlighting $ unsolved ++ warnings--      stSyntaxInfo `modifyTCLens` \inf -> (inf `mappend` toks) `mappend` warningInfo--      whenM (optGenerateVimFile <$> commandLineOptions) $-        -- Generate Vim file.-        withScope_ scope $ generateVimFile $ filePath $ srcFilePath $ file-    reportSLn "import.iface.create" 7 "Finished highlighting from type info."--    setScope scope-    reportSLn "scope.top" 50 $ "SCOPE " ++ show scope--    -- TODO: It would be nice if unsolved things were highlighted-    -- after every mutual block.--    openMetas           <- getOpenMetas-    unless (null openMetas) $ do-      reportSLn "import.metas" 10 "We have unsolved metas."-      reportSLn "import.metas" 10 =<< showGoals =<< getGoals--    ifTopLevelAndHighlightingLevelIs NonInteractive printUnsolvedInfo--    -- Andreas, 2016-08-03, issue #964-    -- When open metas are allowed,-    -- permanently freeze them now by turning them into postulates.-    -- This will enable serialization.-    -- savedMetaStore <- useTC stMetaStore-    allowUnsolved <- optAllowUnsolved <$> pragmaOptions-    unless (includeStateChanges isMain) $-      -- Andreas, 2018-11-15, re issue #3393:-      -- We do not get here when checking the main module-      -- (then includeStateChanges is True).-      when allowUnsolved $ do-        reportSLn "import.iface.create" 7 "Turning unsolved metas (if any) into postulates."-        withCurrentModule (scope ^. scopeCurrent) openMetasToPostulates-        -- Clear constraints as they might refer to what-        -- they think are open metas.-        stAwakeConstraints    `setTCLens` []-        stSleepingConstraints `setTCLens` []--    -- Serialization.-    reportSLn "import.iface.create" 7 "Starting serialization."-    i <- Bench.billTo [Bench.Serialization, Bench.BuildInterface] $-      buildInterface source fileType topLevel options--    reportS "tc.top" 101 $-      "Signature:" :-      [ unlines-          [ prettyShow x-          , "  type: " ++ show (defType def)-          , "  def:  " ++ show cc-          ]-      | (x, def) <- HMap.toList $ iSignature i ^. sigDefinitions,-        Function{ funCompiled = cc } <- [theDef def]-      ]-    reportSLn "import.iface.create" 7 "Finished serialization."--    mallWarnings <- getMaybeWarnings' isMain ErrorWarnings--    reportSLn "import.iface.create" 7 "Considering writing to interface file."-    i <- case (mallWarnings, isMain) of-      (SomeWarnings allWarnings, _) -> 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 "We have warnings, skipping writing interface file."-        return i-      (_, MainInterface ScopeCheck) -> do-        reportSLn "import.iface.create" 7 "We are just scope-checking, skipping writing interface file."-        return i-      _ -> Bench.billTo [Bench.Serialization] $ do-        reportSLn "import.iface.create" 7 "Actually calling writeInterface."-        -- The file was successfully type-checked (and no warnings were-        -- encountered), so the interface should be written out.-        ifile <- toIFile file-        writeInterface ifile i-    reportSLn "import.iface.create" 7 "Finished (or skipped) writing to interface file."--    -- -- Restore the open metas, as we might continue in interaction mode.-    -- Actually, we do not serialize the metas if checking the MainInterface-    -- stMetaStore `setTCLens` savedMetaStore--    -- Profiling: Print statistics.-    printStatistics 30 (Just mname) =<< getStatistics--    -- Get the statistics of the current module-    -- and add it to the accumulated statistics.-    localStatistics <- getStatistics-    lensAccumStatistics `modifyTCLens` Map.unionWith (+) localStatistics-    verboseS "profile" 1 $ reportSLn "import.iface" 5 "Accumulated statistics."--    return $ first constructIScope (i, mallWarnings)--getUniqueMetasRanges :: [MetaId] -> TCM [Range]-getUniqueMetasRanges = fmap (nubOn id) . mapM getMetaRange--getUnsolvedMetas :: TCM [Range]-getUnsolvedMetas = do-  openMetas            <- getOpenMetas-  interactionMetas     <- getInteractionMetas-  getUniqueMetasRanges (openMetas List.\\ interactionMetas)--getAllUnsolved :: TCM [TCWarning]-getAllUnsolved = do-  unsolvedInteractions <- getUniqueMetasRanges =<< getInteractionMetas-  unsolvedConstraints  <- getAllConstraints-  unsolvedMetas        <- getUnsolvedMetas--  let checkNonEmpty c rs = c rs <$ guard (not $ null rs)--  mapM warning_ $ catMaybes-                [ checkNonEmpty UnsolvedInteractionMetas unsolvedInteractions-                , checkNonEmpty UnsolvedMetaVariables    unsolvedMetas-                , checkNonEmpty UnsolvedConstraints      unsolvedConstraints ]----- | Collect all warnings that have accumulated in the state.--getAllWarnings :: WhichWarnings -> TCM [TCWarning]-getAllWarnings = getAllWarnings' NotMainInterface---- | Expert version of 'getAllWarnings'; if 'isMain' is a--- 'MainInterface', the warnings definitely include also unsolved--- warnings.--getAllWarnings' :: MainInterface -> WhichWarnings -> TCM [TCWarning]-getAllWarnings' isMain ww = do-  unsolved            <- getAllUnsolved-  collectedTCWarnings <- useTC stTCWarnings--  let showWarn w = classifyWarning w <= ww &&-                    not (null unsolved && onlyShowIfUnsolved w)--  fmap (filter (showWarn . tcWarning))-    $ applyFlagsToTCWarnings' isMain $ reverse-    $ unsolved ++ collectedTCWarnings--getMaybeWarnings :: WhichWarnings -> TCM MaybeWarnings-getMaybeWarnings = getMaybeWarnings' NotMainInterface--getMaybeWarnings' :: MainInterface -> WhichWarnings -> TCM MaybeWarnings-getMaybeWarnings' isMain ww = do-  allWarnings <- getAllWarnings' isMain ww-  return $ if null allWarnings-    -- Andreas, issue 964: not checking null interactionPoints-    -- anymore; we want to serialize with open interaction points now!-           then NoWarnings-           else SomeWarnings allWarnings--getAllWarningsOfTCErr :: TCErr -> TCM [TCWarning]-getAllWarningsOfTCErr err = case err of-  TypeError tcst cls -> case clValue cls of-    NonFatalErrors{} -> return []-    _ -> localTCState $ do-      putTC tcst-      ws <- getAllWarnings AllWarnings-      -- We filter out the unsolved(Metas/Constraints) to stay-      -- true to the previous error messages.-      return $ filter (not . isUnsolvedWarning . tcWarning) ws-  _ -> return []---- | Reconstruct the 'iScope' (not serialized)---   from the 'iInsideScope' (serialized).--constructIScope :: Interface -> Interface-constructIScope i = billToPure [ Deserialization ] $-  i{ iScope = publicModules $ iInsideScope i }---- | Builds an interface for the current module, which should already--- have been successfully type checked.--buildInterface-  :: Text-     -- ^ Source code.-  -> FileType-     -- ^ Agda file? Literate Agda file?-  -> TopLevelInfo-     -- ^ 'TopLevelInfo' for the current module.-  -> [OptionsPragma]-     -- ^ Options set in @OPTIONS@ pragmas.-  -> TCM Interface-buildInterface source fileType topLevel pragmas = do-    reportSLn "import.iface" 5 "Building interface..."-    let m = topLevelModuleName topLevel-    scope'  <- getScope-    let scope = set scopeCurrent m scope'-    -- Andreas, 2014-05-03: killRange did not result in significant reduction-    -- of .agdai file size, and lost a few seconds performance on library-test.-    -- Andreas, Makoto, 2014-10-18 AIM XX: repeating the experiment-    -- with discarding also the nameBindingSite in QName:-    -- Saves 10% on serialization time (and file size)!-    ---    -- NOTE: We no longer discard all nameBindingSites (but the commit-    -- that introduced this change seems to have made Agda a bit-    -- faster and interface file sizes a bit smaller, at least for the-    -- standard library).-    builtin     <- useTC stLocalBuiltins-    ms          <- getImports-    mhs         <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms-    foreignCode <- useTC stForeignCode-    -- Ulf, 2016-04-12:-    -- Non-closed display forms are not applicable outside the module anyway,-    -- and should be dead-code eliminated (#1928).-    display <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms-    -- TODO: Kill some ranges?-    (display, sig) <- eliminateDeadCode display =<< getSignature-    userwarns      <- useTC stLocalUserWarnings-    importwarn     <- useTC stWarningOnImport-    syntaxInfo     <- useTC stSyntaxInfo-    optionsUsed    <- useTC stPragmaOptions-    partialDefs    <- useTC stLocalPartialDefs--    -- Andreas, 2015-02-09 kill ranges in pattern synonyms before-    -- serialization to avoid error locations pointing to external files-    -- when expanding a pattern synonym.-    patsyns <- killRange <$> getPatternSyns-    let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin-    warnings <- getAllWarnings AllWarnings-    reportSLn "import.iface" 7 "  instantiating all meta variables"-    i <- instantiateFull Interface-      { iSourceHash      = hashText source-      , iSource          = source-      , iFileType        = fileType-      , iImportedModules = mhs-      , iModuleName      = m-      , iScope           = empty -- publicModules scope-      , iInsideScope     = topLevelScope topLevel-      , iSignature       = sig-      , iDisplayForms    = display-      , iUserWarnings    = userwarns-      , iImportWarning   = importwarn-      , iBuiltin         = builtin'-      , iForeignCode     = foreignCode-      , iHighlighting    = syntaxInfo-      , iPragmaOptions   = pragmas-      , iOptionsUsed     = optionsUsed-      , iPatternSyns     = patsyns-      , iWarnings        = warnings-      , iPartialDefs     = partialDefs-      }-    reportSLn "import.iface" 7 "  interface complete"-    return i---- | Returns (iSourceHash, iFullHash)---   We do not need to check that the file exist because we only---   accept @InterfaceFile@ as an input and not arbitrary @AbsolutePath@!-getInterfaceFileHashes :: AbsolutePath -> TCM (Maybe (Hash, Hash))-getInterfaceFileHashes fp = runMaybeT $ do-  mifile <- MaybeT $ liftIO $ mkInterfaceFile fp-  MaybeT $ getInterfaceFileHashes' mifile--getInterfaceFileHashes' :: InterfaceFile -> TCM (Maybe (Hash, Hash))-getInterfaceFileHashes' fp = do-  let ifile = filePath $ intFilePath fp-  (s, close) <- liftIO $ readBinaryFile' ifile-  let hs = decodeHashes s-  liftIO $ maybe 0 (uncurry (+)) hs `seq` close-  return hs--moduleHash :: ModuleName -> TCM Hash-moduleHash m = iFullHash <$> getInterface m---- | True if the first file is newer than the second file. If a file doesn't--- exist it is considered to be infinitely old.-isNewerThan :: FilePath -> FilePath -> IO Bool-isNewerThan new old = do-    newExist <- doesFileExist new-    oldExist <- doesFileExist old-    if not (newExist && oldExist)-        then return newExist-        else do-            newT <- getModificationTime new-            oldT <- getModificationTime old-            return $ newT >= oldT+module Agda.Interaction.Imports+  ( Mode, pattern ScopeCheck, pattern TypeCheck++  , CheckResult (CheckResult)+  , crModuleInfo+  , crInterface+  , crWarnings+  , crMode+  , crSource++  , Source(..)+  , scopeCheckImport+  , parseSource+  , typeCheckMain++  -- Currently only used by test/api/Issue1168.hs:+  , readInterface+  ) where++import Prelude hiding (null)++import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Trans.Maybe+import qualified Control.Exception as E++#if __GLASGOW_HASKELL__ < 808+import Control.Monad.Fail (MonadFail)+#endif++import Data.Either (lefts)+import qualified Data.Map as Map+import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe+import Data.Map (Map)+import qualified Data.HashMap.Strict as HMap+import Data.Text (Text)+import qualified Data.Text.Lazy as TL++import System.Directory (doesFileExist, removeFile)+import System.FilePath ((</>), takeDirectory)++import Agda.Benchmarking++import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Abstract.Name+import Agda.Syntax.Common+import Agda.Syntax.Parser+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base+import Agda.Syntax.Translation.ConcreteToAbstract++import Agda.TypeChecking.Errors+import Agda.TypeChecking.Warnings hiding (warnings)+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rewriting.Confluence ( checkConfluenceOfRules )+import Agda.TypeChecking.MetaVars ( openMetasToPostulates )+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Serialise+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.Pretty as P+import Agda.TypeChecking.DeadCode+import qualified Agda.TypeChecking.Monad.Benchmark as Bench++import Agda.TheTypeChecker++import Agda.Interaction.BasicOps ( getGoals, showGoals )+import Agda.Interaction.FindFile+import Agda.Interaction.Highlighting.Generate+import Agda.Interaction.Highlighting.Precise  ( 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.Warnings (unsolvedWarnings)+import Agda.Interaction.Response+  (RemoveTokenBasedHighlighting(KeepHighlighting))++import Agda.Utils.FileName+import Agda.Utils.Lens+import Agda.Utils.Maybe+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.IO.Binary+import Agda.Utils.Pretty hiding (Mode)+import Agda.Utils.Hash+import qualified Agda.Utils.Trie as Trie++import Agda.Utils.Impossible++-- | Whether to ignore interfaces (@.agdai@) other than built-in modules++ignoreInterfaces :: HasOptions m => m Bool+ignoreInterfaces = optIgnoreInterfaces <$> commandLineOptions++-- | Whether to ignore all interface files (@.agdai@)++ignoreAllInterfaces :: HasOptions m => m Bool+ignoreAllInterfaces = optIgnoreAllInterfaces <$> commandLineOptions++-- | The decorated source code.++data Source = Source+  { srcText        :: TL.Text               -- ^ Source code.+  , srcFileType    :: FileType              -- ^ Source file type+  , srcOrigin      :: SourceFile            -- ^ Source location at the time of its parsing+  , srcModule      :: C.Module              -- ^ The parsed module.+  , srcModuleName  :: C.TopLevelModuleName  -- ^ The top-level module name.+  , srcProjectLibs :: [AgdaLibFile]         -- ^ The .agda-lib file(s) of the project this file belongs to.+  }++-- | Parses a source file and prepares the 'Source' record.++parseSource :: SourceFile -> TCM Source+parseSource sourceFile@(SourceFile f) = Bench.billTo [Bench.Parsing] $ do+  source                <- runPM $ readFilePM f+  (parsedMod, fileType) <- runPM $+                           parseFile moduleParser f $ TL.unpack source+  parsedModName         <- moduleName f parsedMod+  let sourceDir = takeDirectory $ filePath f+  useLibs <- optUseLibs <$> commandLineOptions+  libs <- getAgdaLibFiles sourceDir+  return Source+    { srcText        = source+    , srcFileType    = fileType+    , srcOrigin      = sourceFile+    , srcModule      = parsedMod+    , srcModuleName  = parsedModName+    , srcProjectLibs = libs+    }++srcDefaultPragmas :: Source -> [OptionsPragma]+srcDefaultPragmas src = map _libPragmas (srcProjectLibs src)++srcFilePragmas :: Source -> [OptionsPragma]+srcFilePragmas src = pragmas+  where+  cpragmas = C.modPragmas (srcModule src)+  pragmas = [ opts | C.OptionsPragma _ opts <- cpragmas ]++srcPragmas :: Source -> [OptionsPragma]+srcPragmas src = srcDefaultPragmas src ++ srcFilePragmas src++-- | Set options from a 'Source' pragma, using the source+--   ranges of the pragmas for error reporting.+setOptionsFromSourcePragmas :: Source -> TCM ()+setOptionsFromSourcePragmas src =+  setCurrentRange (C.modPragmas . srcModule $ src) $+    mapM_ setOptionsFromPragma (srcPragmas src)++-- | Is the aim to type-check the top-level module, or only to+-- scope-check it?++data Mode+  = ScopeCheck+  | TypeCheck+  deriving (Eq, Show)++-- | Are we loading the interface for the user-loaded file+--   or for an import?+data MainInterface+  = MainInterface Mode -- ^ For the main file.+                       --+                       --   In this case state changes inflicted by+                       --   'createInterface' are preserved.+  | NotMainInterface   -- ^ For an imported file.+                       --+                       --   In this case state changes inflicted by+                       --   'createInterface' are not preserved.+  deriving (Eq, Show)++-- | Should state changes inflicted by 'createInterface' be preserved?++includeStateChanges :: MainInterface -> Bool+includeStateChanges (MainInterface _) = True+includeStateChanges NotMainInterface  = False++-- | The kind of interface produced by 'createInterface'+moduleCheckMode :: MainInterface -> ModuleCheckMode+moduleCheckMode = \case+    MainInterface TypeCheck                       -> ModuleTypeChecked+    NotMainInterface                              -> ModuleTypeChecked+    MainInterface ScopeCheck                      -> ModuleScopeChecked++-- | Merge an interface into the current proof state.+mergeInterface :: Interface -> TCM ()+mergeInterface i = do+    let sig     = iSignature i+        builtin = Map.toList $ iBuiltin i+        prim    = [ x | (_,Prim x) <- builtin ]+        bi      = Map.fromList [ (x,Builtin t) | (x,Builtin t) <- builtin ]+        warns   = iWarnings i+    bs <- getsTC stBuiltinThings+    reportSLn "import.iface.merge" 10 "Merging interface"+    reportSLn "import.iface.merge" 20 $+      "  Current builtins " ++ show (Map.keys bs) ++ "\n" +++      "  New builtins     " ++ show (Map.keys bi)+    let check b = case (b1, b2) of+            (Builtin x, Builtin y)+              | x == y    -> return ()+              | otherwise -> typeError $ DuplicateBuiltinBinding b x y+            _ -> __IMPOSSIBLE__+          where+            Just b1 = Map.lookup b bs+            Just b2 = Map.lookup b bi+    mapM_ (check . fst) (Map.toList $ Map.intersection bs bi)+    addImportedThings sig bi+      (iPatternSyns i)+      (iDisplayForms i)+      (iUserWarnings i)+      (iPartialDefs i)+      warns+    reportSLn "import.iface.merge" 20 $+      "  Rebinding primitives " ++ show prim+    mapM_ rebind prim+    whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do+      reportSLn "import.iface.confluence" 20 $ "  Checking confluence of imported rewrite rules"+      checkConfluenceOfRules confChk $ concat $ HMap.elems $ sig ^. sigRewriteRules+    where+        rebind (x, q) = do+            PrimImpl _ pf <- lookupPrimitiveFunction x+            stImportedBuiltins `modifyTCLens` Map.insert x (Prim pf{ primFunName = q })++addImportedThings+  :: Signature+  -> BuiltinThings PrimFun+  -> A.PatternSynDefns+  -> DisplayForms+  -> Map A.QName Text      -- ^ Imported user warnings+  -> Set QName             -- ^ Name of imported definitions which are partial+  -> [TCWarning]+  -> TCM ()+addImportedThings isig ibuiltin patsyns display userwarn partialdefs warnings = do+  stImports              `modifyTCLens` \ imp -> unionSignatures [imp, isig]+  stImportedBuiltins     `modifyTCLens` \ imp -> Map.union 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+  stTCWarnings           `modifyTCLens` \ imp -> imp `List.union` warnings+  addImportedInstances isig++-- | Scope checks the given module. A proper version of the module+-- name (with correct definition sites) is returned.++scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)+scopeCheckImport x = do+    reportSLn "import.scope" 5 $ "Scope checking " ++ prettyShow x+    verboseS "import.scope" 10 $ do+      visited <- prettyShow <$> getPrettyVisitedModules+      reportSLn "import.scope" 10 $ "  visited: " ++ visited+    -- Since scopeCheckImport is called from the scope checker,+    -- we need to reimburse her account.+    i <- Bench.billTo [] $ getNonMainInterface (toTopLevelModuleName x) Nothing+    addImport x++    -- If that interface was supposed to raise a warning on import, do so.+    whenJust (iImportWarning i) $ warning . UserWarning++    -- let s = publicModules $ iInsideScope i+    let s = iScope i+    return (iModuleName i `withRangesOfQ` mnameToConcrete x, 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 :: C.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, miWarnings mi) of+      (MainInterface ScopeCheck, _) -> return ()+      (_, _:_)                      -> return ()+      _                             -> storeDecodedModule mi++    reportS "warning.import" 10+      [ "module: " ++ show (C.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.++data CheckResult = CheckResult'+  { crModuleInfo :: ModuleInfo+  , crSource'    :: Source+  }++-- | Flattened unidirectional pattern for 'CheckResult' for destructuring inside+--   the 'ModuleInfo' field.+pattern CheckResult :: Interface -> [TCWarning] -> ModuleCheckMode -> Source -> CheckResult+pattern CheckResult { crInterface, crWarnings, crMode, crSource } <- CheckResult'+    { crModuleInfo = ModuleInfo+        { miInterface = crInterface+        , miWarnings = crWarnings+        , miMode = crMode+        }+    , crSource' = crSource+    }++-- | 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.+--+--   First, the primitive modules are imported.+--   Then, @getInterface@ is called to do the main work.+--+--   If the 'Mode' is 'ScopeCheck', then type-checking is not+--   performed, only scope-checking. (This may include type-checking+--   of imported modules.) In this case the generated, partial+--   interface is not stored in the state ('stDecodedModules'). Note,+--   however, that if the file has already been type-checked, then a+--   complete interface is returned.++typeCheckMain+  :: Mode+     -- ^ Should the file be type-checked, or only scope-checked?+  -> Source+     -- ^ The decorated source code.+  -> TCM CheckResult+typeCheckMain mode src = do+  -- liftIO $ putStrLn $ "This is typeCheckMain " ++ prettyShow f+  -- liftIO . putStrLn . show =<< getVerbosity+  reportSLn "import.main" 10 "Importing the primitive modules."+  libdirPrim <- liftIO getPrimitiveLibDir+  reportSLn "import.main" 20 $ "Library primitive dir = " ++ show libdirPrim+  -- Turn off import-chasing messages.+  -- We have to modify the persistent verbosity setting, since+  -- getInterface resets the current verbosity settings to the persistent ones.+  bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do+    Lens.modifyPersistentVerbosity (Trie.delete [])  -- set root verbosity to 0++    -- We don't want to generate highlighting information for Agda.Primitive.+    withHighlightingLevel None $+      forM_ (Set.map (libdirPrim </>) Lens.primitiveModules) $ \f -> do+        primSource <- parseSource (SourceFile $ mkAbsolute f)+        checkModuleName' (srcModuleName primSource) (srcOrigin primSource)+        void $ getNonMainInterface (srcModuleName primSource) (Just primSource)++  reportSLn "import.main" 10 $ "Done importing the primitive modules."++  -- Now do the type checking via getInterface.+  checkModuleName' (srcModuleName src) (srcOrigin src)++  -- For the main interface, we also remember the pragmas from the file+  setOptionsFromSourcePragmas src++  mi <- getInterface (srcModuleName src) (MainInterface mode) (Just src)++  stCurrentModule `setTCLens` Just (iModuleName (miInterface mi))++  return $ CheckResult' mi src+  where+  checkModuleName' m f =+    -- Andreas, 2016-07-11, issue 2092+    -- The error range should be set to the file with the wrong module name+    -- not the importing one (which would be the default).+    setCurrentRange m $ checkModuleName m f Nothing++-- | Tries to return the interface associated to the given (imported) module.+--   The time stamp of the relevant interface file is also returned.+--   Calls itself recursively for the imports of the given module.+--   May type check the module.+--   An error is raised if a warning is encountered.+--+--   Do not use this for the main file, use 'typeCheckMain' instead.++getNonMainInterface+  :: C.TopLevelModuleName+  -> Maybe Source+     -- ^ Optional: the source code and some information about the source code.+  -> TCM Interface+getNonMainInterface x msrc = do+  -- Preserve/restore the current pragma options, which will be mutated when loading+  -- and checking the interface.+  mi <- bracket_ (useTC stPragmaOptions) (stPragmaOptions `setTCLens`) $+          getInterface x NotMainInterface msrc+  tcWarningsToError $ miWarnings mi+  return (miInterface mi)++-- | A more precise variant of 'getNonMainInterface'. If warnings are+-- encountered then they are returned instead of being turned into+-- errors.++getInterface+  :: C.TopLevelModuleName+  -> MainInterface+  -> 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++     alreadyVisited x isMain currentOptions $ do+      file <- maybe (findFile x) (pure . srcOrigin) msrc -- may require source to exist++      reportSLn "import.iface" 10 $ "  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++      let recheck = \reason -> do+            reportSLn "import.iface" 5 $ concat ["  ", prettyShow x, " is not up-to-date because ", reason, "."]+            setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC+            case isMain of+              MainInterface _ -> createInterface x file isMain msrc+              NotMainInterface -> createInterfaceIsolated x file msrc++      either recheck pure stored++-- | Check if the options used for checking an imported module are+--   compatible with the current options. Raises Non-fatal errors if+--   not.+checkOptionsCompatible :: PragmaOptions -> PragmaOptions -> ModuleName -> TCM Bool+checkOptionsCompatible current imported importedModule = flip execStateT True $ do+  reportSDoc "import.iface.options" 5 $ P.nest 2 $ "current options  =" P.<+> showOptions current+  reportSDoc "import.iface.options" 5 $ P.nest 2 $ "imported options =" P.<+> showOptions imported+  forM_ coinfectiveOptions $ \ (opt, optName) -> do+    unless (opt current `implies` opt imported) $ do+      put False+      warning (CoInfectiveImport optName importedModule)+  forM_ infectiveOptions $ \ (opt, optName) -> do+    unless (opt imported `implies` opt current) $ do+      put False+      warning (InfectiveImport optName importedModule)+  where+    implies :: Bool -> Bool -> Bool+    p `implies` q = p <= q++    showOptions opts = P.prettyList (map (\ (o, n) -> (P.text n <> ": ") P.<+> P.pretty (o opts))+                                 (coinfectiveOptions ++ infectiveOptions))+++-- | Compare options and return collected warnings.+-- | Returns `Nothing` if warning collection was skipped.++getOptionsCompatibilityWarnings :: MainInterface -> Bool -> PragmaOptions -> Interface -> TCM (Maybe [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) (iModuleName i)) $+    throwError "No warnings to collect because options were compatible"+  lift $ getAllWarnings' isMain ErrorWarnings++-- | Try to get the interface from interface file or cache.++getStoredInterface+  :: C.TopLevelModuleName+     -- ^ Module name of file we process.+  -> SourceFile+     -- ^ File we process.+  -> Maybe Source+  -> ExceptT String TCM ModuleInfo+getStoredInterface x file msrc = do+  -- Check whether interface file exists and is in cache+  --  in the correct version (as testified by the interface file hash).+  --+  -- This is a lazy action which may be skipped if there is no cached interface+  -- and we're ignoring interface files for some reason.+  let getIFileHashesET = do+        -- Check that the interface file exists and return its hash.+        ifile <- maybeToExceptT "the interface file could not be found" $ MaybeT $+          findInterfaceFile' file++        -- Check that the interface file exists and return its hash.+        hashes <- maybeToExceptT "the interface file hash could not be read" $ MaybeT $ liftIO $+          getInterfaceFileHashes ifile++        return (ifile, hashes)++  -- Examine the hash of the interface file. If it is different from the+  -- stored version (in stDecodedModules), or if there is no stored version,+  -- read and decode it. Otherwise use the stored version.+  --+  -- This is a lazy action which may be skipped if the cached or on-disk interface+  -- is invalid, missing, or skipped for some other reason.+  let checkSourceHashET ifaceH = do+        sourceH <- case msrc of+                    Nothing -> liftIO $ hashTextFile (srcFilePath file)+                    Just src -> return $ hashText (srcText src)++        unless (sourceH == ifaceH) $+          throwError $ concat+            [ "the source hash (", show sourceH, ")"+            , " does not match the source hash for the interface (", show ifaceH, ")"+            ]++        reportSLn "import.iface" 5 $ concat ["  ", prettyShow x, " is up-to-date."]++  -- Check if we have cached the module.+  cachedE <- runExceptT $ maybeToExceptT "the interface has not been decoded" $ MaybeT $+      lift $ getDecodedModule x++  case cachedE of+    -- If it's cached ignoreInterfaces has no effect;+    -- to avoid typechecking a file more than once.+    Right mi -> do+      (ifile, hashes) <- getIFileHashesET++      let ifp = filePath $ intFilePath ifile+      let i = miInterface mi++      -- Make sure the hashes match.+      let cachedIfaceHash = iFullHash i+      let fileIfaceHash = snd hashes+      unless (cachedIfaceHash == fileIfaceHash) $ do+        lift $ dropDecodedModule x+        reportSLn "import.iface" 50 $ "  cached hash = " ++ show cachedIfaceHash+        reportSLn "import.iface" 50 $ "  stored hash = " ++ show fileIfaceHash+        reportSLn "import.iface" 5 $ "  file is newer, re-reading " ++ ifp+        throwError $ concat+          [ "the cached interface hash (", show cachedIfaceHash, ")"+          , " does not match interface file (", show fileIfaceHash, ")"+          ]++      Bench.billTo [Bench.Deserialization] $ do+        checkSourceHashET (iSourceHash i)++        reportSLn "import.iface" 5 $ "  using stored version of " ++ (filePath $ intFilePath ifile)+        loadDecodedModule file mi++    Left whyNotCached -> withExceptT (\e -> concat [whyNotCached, " and ", e]) $ do+      whenM ignoreAllInterfaces $+        throwError "we're ignoring all interface files"++      whenM ignoreInterfaces $+        unlessM (lift $ Lens.isBuiltinModule (filePath $ srcFilePath file)) $+            throwError "we're ignoring non-builtin interface files"++      (ifile, hashes) <- getIFileHashesET++      let ifp = (filePath . intFilePath $ ifile)++      Bench.billTo [Bench.Deserialization] $ do+        checkSourceHashET (fst hashes)++        reportSLn "import.iface" 5 $ "  no stored version, reading " ++ ifp++        i <- maybeToExceptT "bad interface, re-type checking" $ MaybeT $+          readInterface ifile++        -- Ensure that the given module name matches the one in the file.+        let topLevelName = toTopLevelModuleName $ iModuleName i+        unless (topLevelName == x) $+          -- Andreas, 2014-03-27 This check is now done in the scope checker.+          -- checkModuleName topLevelName file+          lift $ typeError $ OverlappingProjects (srcFilePath file) topLevelName x++        isPrimitiveModule <- lift $ Lens.isPrimitiveModule (filePath $ srcFilePath file)++        lift $ chaseMsg "Loading " x $ Just ifp+        -- print imported warnings+        let ws = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (iWarnings i)+        unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws++        loadDecodedModule file $ ModuleInfo+          { miInterface = i+          , miWarnings = []+          , miPrimitive = isPrimitiveModule+          , miMode = ModuleTypeChecked+          }+++loadDecodedModule+  :: SourceFile+     -- ^ File we process.+  -> ModuleInfo+  -> ExceptT String TCM ModuleInfo+loadDecodedModule file mi = do+  let fp = filePath $ srcFilePath file+  let i = miInterface mi++  -- Check that it's the right version+  reportSLn "import.iface" 5 $ "  imports: " ++ prettyShow (iImportedModules i)++  -- We set the pragma options of the skipped file here, so that+  -- we can check that they are compatible with those of the+  -- imported modules. Also, if the top-level file is skipped we+  -- want the pragmas to apply to interactive commands in the UI.+  -- Jesper, 2021-04-18: Check for changed options in library files!+  -- (see #5250)+  libOptions <- lift $ getLibraryOptions $ takeDirectory fp+  lift $ mapM_ setOptionsFromPragma (libOptions ++ iFilePragmaOptions i)++  -- Check that options that matter haven't changed compared to+  -- current options (issue #2487)+  unlessM (lift $ Lens.isBuiltinModule fp) $ do+    currentOptions <- useTC stPragmaOptions+    let disagreements =+          [ optName | (opt, optName) <- restartOptions,+                      opt currentOptions /= opt (iOptionsUsed i) ]+    unless (null disagreements) $ do+      reportSLn "import.iface.options" 4 $ concat+        [ "  Changes in the following options in "+        , prettyShow fp+        , ", re-typechecking: "+        , prettyShow disagreements+        ]+      throwError "options changed"++  -- If any of the imports are newer we need to retype check+  badHashMessages <- fmap lefts $ forM (iImportedModules i) $ \(impName, impHash) -> runExceptT $ do+    reportSLn "import.iface" 30 $ concat ["Checking that module hash of import ", prettyShow impName, " matches ", prettyShow impHash ]+    latestImpHash <- lift $ lift $ setCurrentRange impName $ moduleHash impName+    reportSLn "import.iface" 30 $ concat ["Done checking module hash of import ", prettyShow impName]+    when (impHash /= latestImpHash) $+      throwError $ concat+        [ "module hash for imported module ", prettyShow impName, " is out of date"+        , " (import cached=", prettyShow impHash, ", latest=", prettyShow latestImpHash, ")"+        ]++  unlessNull badHashMessages (throwError . unlines)++  reportSLn "import.iface" 5 "  New module. Let's check it out."+  lift $ mergeInterface i+  Bench.billTo [Bench.Highlighting] $+    lift $ ifTopLevelAndHighlightingLevelIs NonInteractive $+      highlightFromInterface i file++  return mi++-- | Run the type checker on a file and create an interface.+--+--   Mostly, this function calls 'createInterface'.+--   But if it is not the main module we check,+--   we do it in a fresh state, suitably initialize,+--   in order to forget some state changes after successful type checking.++createInterfaceIsolated+  :: C.TopLevelModuleName+     -- ^ Module name of file we process.+  -> SourceFile+     -- ^ File we process.+  -> Maybe Source+     -- ^ Optional: the source code and some information about the source code.+  -> TCM ModuleInfo+createInterfaceIsolated x file msrc = do+      cleanCachedLog++      ms          <- getImportPath+      range       <- asksTC envRange+      call        <- asksTC envCall+      mf          <- useTC stModuleToSource+      vs          <- getVisitedModules+      ds          <- getDecodedModules+      opts        <- stPersistentOptions . stPersistentState <$> getTC+      isig        <- useTC stImports+      ibuiltin    <- useTC stImportedBuiltins+      display     <- useTC stImportsDisplayForms+      userwarn    <- useTC stImportedUserWarnings+      partialdefs <- useTC stImportedPartialDefs+      ipatsyns <- getPatternSynImports+      ho       <- getInteractionOutputCallback+      -- 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 =<<) $+           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+               setDecodedModules ds+               setCommandLineOptions opts+               setInteractionOutputCallback ho+               stModuleToSource `setTCLens` mf+               setVisitedModules vs+               addImportedThings isig ibuiltin ipatsyns display userwarn partialdefs []++               r  <- createInterface x file NotMainInterface msrc+               mf' <- useTC stModuleToSource+               ds' <- getDecodedModules+               return (r, mf', ds')++      stModuleToSource `setTCLens` newModToSource+      setDecodedModules newDecodedModules++      -- We skip the file which has just been type-checked to+      -- be able to forget some of the local state from+      -- checking the module.+      -- Note that this doesn't actually read the interface+      -- file, only the cached interface. (This comment is not+      -- correct, see+      -- test/Fail/customised/NestedProjectRoots.err.)+      validated <- runExceptT $ loadDecodedModule file mi++      -- NOTE: This attempts to type-check FOREVER if for some+      -- reason it continually fails to validate interface.+      let recheckOnError = \msg -> do+            reportSLn "import.iface" 1 $ "Failed to validate just-loaded interface: " ++ msg+            createInterfaceIsolated x file msrc++      either recheckOnError pure validated+++-- | Formats and outputs the "Checking", "Finished" and "Loading " messages.++chaseMsg+  :: String               -- ^ The prefix, like @Checking@, @Finished@, @Loading @.+  -> C.TopLevelModuleName -- ^ The module name.+  -> Maybe String         -- ^ Optionally: the file name.+  -> TCM ()+chaseMsg kind x file = do+  indentation <- (`replicate` ' ') <$> asksTC (pred . length . envImportPath)+  let maybeFile = caseMaybe file "." $ \ f -> " (" ++ f ++ ")."+      vLvl | kind == "Checking" = 1+           | otherwise          = 2+  reportSLn "import.chase" vLvl $ concat+    [ indentation, kind, " ", prettyShow x, maybeFile ]++-- | Print the highlighting information contained in the given interface.++highlightFromInterface+  :: Interface+  -> SourceFile+     -- ^ The corresponding file.+  -> TCM ()+highlightFromInterface i file = do+  reportSLn "import.iface" 5 $+    "Generating syntax info for " ++ filePath (srcFilePath file) +++    " (read from interface)."+  printHighlightingInfo KeepHighlighting (iHighlighting i)++-- | Read interface file corresponding to a module.++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+      IOException _ _ e -> do+        reportSLn "" 0 $ "IO exception: " ++ show e+        return Nothing   -- Work-around for file locking bug.+                         -- TODO: What does this refer to? Please+                         -- document.+      e -> throwError e++-- | Writes the given interface to the given file.+--+-- The written interface is decoded and returned.++writeInterface :: AbsolutePath -> Interface -> TCM Interface+writeInterface file i = let fp = filePath file in do+    reportSLn "import.iface.write" 5  $+      "Writing interface file " ++ fp ++ "."+    -- Andreas, 2015-07-13+    -- After QName memoization (AIM XXI), scope serialization might be cheap enough.+    -- -- Andreas, Makoto, 2014-10-18 AIM XX:+    -- -- iInsideScope is bloating the interface files, so we do not serialize it?+    -- i <- return $+    --   i { iInsideScope  = emptyScopeInfo+    --     }+    -- [Old: Andreas, 2016-02-02 this causes issue #1804, so don't do it:]+    -- Andreas, 2020-05-13, #1804, #4647: removed private declarations+    -- only when we actually write the interface.+    let filteredIface = i { iInsideScope  = withoutPrivates $ iInsideScope i }+    reportSLn "import.iface.write" 50 $+      "Writing interface file with hash " ++ show (iFullHash filteredIface) ++ "."+    encodedIface <- encodeFile fp filteredIface+    reportSLn "import.iface.write" 5 "Wrote interface file."+#if __GLASGOW_HASKELL__ >= 804+    fromMaybe __IMPOSSIBLE__ <$> (Bench.billTo [Bench.Deserialization] (decode encodedIface))+#else+    return filteredIface+#endif+  `catchError` \e -> do+    reportSLn "" 1 $+      "Failed to write interface " ++ fp ++ "."+    liftIO $+      whenM (doesFileExist fp) $ removeFile fp+    throwError e++-- | Tries to type check a module and write out its interface. The+-- function only writes out an interface file if it does not encounter+-- any warnings.+--+-- If appropriate this function writes out syntax highlighting+-- information.++createInterface+  :: C.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.+  -> TCM ModuleInfo+createInterface mname file isMain msrc = do+  let x = mname+  let fp = filePath $ srcFilePath file+  let checkMsg = case isMain of+                   MainInterface ScopeCheck -> "Reading "+                   _                        -> "Checking"+      withMsgs = bracket_+       (chaseMsg checkMsg x $ Just fp)+       (const $ do ws <- getAllWarnings AllWarnings+                   let classified = classifyWarnings ws+                   let wa' = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (tcWarnings classified)+                   unless (null wa') $+                     reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> wa'+                   when (null (nonFatalErrors classified)) $ chaseMsg "Finished" x Nothing)++  withMsgs $+    Bench.billTo [Bench.TopModule mname] $+    localTC (\e -> e { envCurrentPath = Just (srcFilePath file) }) $ do++    let onlyScope = isMain == MainInterface ScopeCheck++    reportSLn "import.iface.create" 5 $+      "Creating interface for " ++ prettyShow mname ++ "."+    verboseS "import.iface.create" 10 $ do+      visited <- prettyShow <$> getPrettyVisitedModules+      reportSLn "import.iface.create" 10 $ "  visited: " ++ visited++    src <- maybe (parseSource file) pure msrc++    let srcPath = srcFilePath $ srcOrigin src++    fileTokenInfo <- Bench.billTo [Bench.Highlighting] $+                       generateTokenInfoFromSource+                         srcPath (TL.unpack $ srcText src)+    stTokens `modifyTCLens` (fileTokenInfo <>)++    setOptionsFromSourcePragmas src++    verboseS "import.iface.create" 15 $ do+      nestingLevel      <- asksTC (pred . length . envImportPath)+      highlightingLevel <- asksTC envHighlightingLevel+      reportSLn "import.iface.create" 15 $ unlines+        [ "  nesting      level: " ++ show nestingLevel+        , "  highlighting level: " ++ show highlightingLevel+        ]++    -- Scope checking.+    reportSLn "import.iface.create" 7 "Starting scope checking."+    topLevel <- Bench.billTo [Bench.Scoping] $ do+      let topDecls = C.modDecls $ srcModule src+      concreteToAbstract_ (TopLevel srcPath mname topDecls)+    reportSLn "import.iface.create" 7 "Finished scope checking."++    let ds    = topLevelDecls topLevel+        scope = topLevelScope topLevel++    -- Highlighting from scope checker.+    reportSLn "import.iface.create" 7 "Starting highlighting from scope."+    Bench.billTo [Bench.Highlighting] $ do+      -- Generate and print approximate syntax highlighting info.+      ifTopLevelAndHighlightingLevelIs NonInteractive $+        printHighlightingInfo KeepHighlighting fileTokenInfo+      ifTopLevelAndHighlightingLevelIsOr NonInteractive onlyScope $+        mapM_ (\ d -> generateAndPrintSyntaxInfo d Partial onlyScope) ds+    reportSLn "import.iface.create" 7 "Finished highlighting from scope."+++    -- Type checking.++    -- Now that all the options are in we can check if caching should+    -- be on.+    activateLoadedFileCache++    -- invalidate cache if pragmas change, TODO move+    cachingStarts+    opts <- useTC stPragmaOptions+    me <- readFromCachedLog+    case me of+      Just (Pragmas opts', _) | opts == opts'+        -> return ()+      _ -> do+        reportSLn "cache" 10 $ "pragma changed: " ++ show (isJust me)+        cleanCachedLog+    writeToCurrentLog $ Pragmas opts++    if onlyScope+      then do+        reportSLn "import.iface.create" 7 "Skipping type checking."+        cacheCurrentLog+      else do+        reportSLn "import.iface.create" 7 "Starting type checking."+        Bench.billTo [Bench.Typing] $ mapM_ checkDeclCached ds `finally_` cacheCurrentLog+        reportSLn "import.iface.create" 7 "Finished type checking."++    -- Ulf, 2013-11-09: Since we're rethrowing the error, leave it up to the+    -- code that handles that error to reset the state.+    -- Ulf, 2013-11-13: Errors are now caught and highlighted in InteractionTop.+    -- catchError_ (checkDecls ds) $ \e -> do+    --   ifTopLevelAndHighlightingLevelIs NonInteractive $+    --     printErrorInfo e+    --   throwError e++    unfreezeMetas++    -- Profiling: Count number of metas.+    verboseS "profile.metas" 10 $ do+      MetaId n <- fresh+      tickN "metas" (fromIntegral n)++    -- Highlighting from type checker.+    reportSLn "import.iface.create" 7 "Starting highlighting from type info."+    Bench.billTo [Bench.Highlighting] $ do++      -- Move any remaining token highlighting to stSyntaxInfo.+      toks <- useTC stTokens+      ifTopLevelAndHighlightingLevelIs NonInteractive $+        printHighlightingInfo KeepHighlighting toks+      stTokens `setTCLens` mempty++      -- Grabbing warnings and unsolved metas to highlight them+      warnings <- getAllWarnings AllWarnings+      unless (null warnings) $ reportSDoc "import.iface.create" 20 $+        "collected warnings: " <> prettyTCM warnings+      unsolved <- getAllUnsolvedWarnings+      unless (null unsolved) $ reportSDoc "import.iface.create" 20 $+        "collected unsolved: " <> prettyTCM unsolved+      let warningInfo =+            convert $ foldMap warningHighlighting $ unsolved ++ warnings++      stSyntaxInfo `modifyTCLens` \inf -> (inf `mappend` toks) `mappend` warningInfo++      whenM (optGenerateVimFile <$> commandLineOptions) $+        -- Generate Vim file.+        withScope_ scope $ generateVimFile $ filePath $ srcPath+    reportSLn "import.iface.create" 7 "Finished highlighting from type info."++    setScope scope+    reportSLn "scope.top" 50 $ "SCOPE " ++ show scope++    -- TODO: It would be nice if unsolved things were highlighted+    -- after every mutual block.++    openMetas           <- getOpenMetas+    unless (null openMetas) $ do+      reportSLn "import.metas" 10 "We have unsolved metas."+      reportSLn "import.metas" 10 =<< showGoals =<< getGoals++    ifTopLevelAndHighlightingLevelIs NonInteractive printUnsolvedInfo++    -- Andreas, 2016-08-03, issue #964+    -- When open metas are allowed,+    -- permanently freeze them now by turning them into postulates.+    -- This will enable serialization.+    -- savedMetaStore <- useTC stMetaStore+    unless (includeStateChanges isMain) $+      -- Andreas, 2018-11-15, re issue #3393:+      -- We do not get here when checking the main module+      -- (then includeStateChanges is True).+      whenM (optAllowUnsolved <$> pragmaOptions) $ do+        reportSLn "import.iface.create" 7 "Turning unsolved metas (if any) into postulates."+        withCurrentModule (scope ^. scopeCurrent) openMetasToPostulates+        -- Clear constraints as they might refer to what+        -- they think are open metas.+        stAwakeConstraints    `setTCLens` []+        stSleepingConstraints `setTCLens` []++    -- Serialization.+    reportSLn "import.iface.create" 7 "Starting serialization."+    i <- Bench.billTo [Bench.Serialization, Bench.BuildInterface] $+      buildInterface src topLevel++    reportS "tc.top" 101 $+      "Signature:" :+      [ unlines+          [ prettyShow q+          , "  type: " ++ show (defType def)+          , "  def:  " ++ show cc+          ]+      | (q, def) <- HMap.toList $ iSignature i ^. sigDefinitions,+        Function{ funCompiled = cc } <- [theDef def]+      ]+    reportSLn "import.iface.create" 7 "Finished serialization."++    mallWarnings <- getAllWarnings' isMain ErrorWarnings++    reportSLn "import.iface.create" 7 "Considering writing to interface file."+    finalIface <- constructIScope <$> case (mallWarnings, isMain) of+      (_:_, _) -> 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 "We have warnings, skipping writing interface file."+        return i+      ([], MainInterface ScopeCheck) -> do+        reportSLn "import.iface.create" 7 "We are just scope-checking, skipping writing interface file."+        return i+      ([], _) -> Bench.billTo [Bench.Serialization] $ do+        reportSLn "import.iface.create" 7 "Actually calling writeInterface."+        -- The file was successfully type-checked (and no warnings were+        -- encountered), so the interface should be written out.+        ifile <- toIFile file+        serializedIface <- writeInterface ifile i+        reportSLn "import.iface.create" 7 "Finished writing to interface file."+        return serializedIface++    -- -- Restore the open metas, as we might continue in interaction mode.+    -- Actually, we do not serialize the metas if checking the MainInterface+    -- stMetaStore `setTCLens` savedMetaStore++    -- Profiling: Print statistics.+    printStatistics 30 (Just mname) =<< getStatistics++    -- Get the statistics of the current module+    -- and add it to the accumulated statistics.+    localStatistics <- getStatistics+    lensAccumStatistics `modifyTCLens` Map.unionWith (+) localStatistics+    verboseS "profile" 1 $ reportSLn "import.iface" 5 "Accumulated statistics."++    isPrimitiveModule <- Lens.isPrimitiveModule (filePath srcPath)++    return ModuleInfo+      { miInterface = finalIface+      , miWarnings = mallWarnings+      , miPrimitive = isPrimitiveModule+      , miMode = moduleCheckMode isMain+      }++-- | Expert version of 'getAllWarnings'; if 'isMain' is a+-- 'MainInterface', the warnings definitely include also unsolved+-- warnings.++getAllWarnings' :: (MonadFail m, ReadTCState m, MonadWarning m) => MainInterface -> WhichWarnings -> m [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!++-- | Reconstruct the 'iScope' (not serialized)+--   from the 'iInsideScope' (serialized).++constructIScope :: Interface -> Interface+constructIScope i = billToPure [ Deserialization ] $+  i{ iScope = publicModules $ iInsideScope i }++-- | Builds an interface for the current module, which should already+-- have been successfully type checked.++buildInterface+  :: Source+     -- ^ 'Source' for the current module.+  -> TopLevelInfo+     -- ^ 'TopLevelInfo' scope information for the current module.+  -> TCM Interface+buildInterface src topLevel = do+    reportSLn "import.iface" 5 "Building interface..."+    let mname = topLevelModuleName topLevel+        source   = srcText src+        fileType = srcFileType src+        defPragmas = srcDefaultPragmas src+        filePragmas  = srcFilePragmas src+    -- Andreas, 2014-05-03: killRange did not result in significant reduction+    -- of .agdai file size, and lost a few seconds performance on library-test.+    -- Andreas, Makoto, 2014-10-18 AIM XX: repeating the experiment+    -- with discarding also the nameBindingSite in QName:+    -- Saves 10% on serialization time (and file size)!+    --+    -- NOTE: We no longer discard all nameBindingSites (but the commit+    -- that introduced this change seems to have made Agda a bit+    -- faster and interface file sizes a bit smaller, at least for the+    -- standard library).+    builtin     <- useTC stLocalBuiltins+    ms          <- getImports+    mhs         <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms+    foreignCode <- useTC stForeignCode+    -- Ulf, 2016-04-12:+    -- Non-closed display forms are not applicable outside the module anyway,+    -- and should be dead-code eliminated (#1928).+    origDisplayForms <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms+    -- TODO: Kill some ranges?+    (display, sig) <- eliminateDeadCode origDisplayForms =<< getSignature+    userwarns      <- useTC stLocalUserWarnings+    importwarn     <- useTC stWarningOnImport+    syntaxInfo     <- useTC stSyntaxInfo+    optionsUsed    <- useTC stPragmaOptions+    partialDefs    <- useTC stLocalPartialDefs++    -- Andreas, 2015-02-09 kill ranges in pattern synonyms before+    -- serialization to avoid error locations pointing to external files+    -- when expanding a pattern synonym.+    patsyns <- killRange <$> getPatternSyns+    let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin+    warnings <- getAllWarnings AllWarnings+    reportSLn "import.iface" 7 "  instantiating all meta variables"+    i <- instantiateFull Interface+      { iSourceHash      = hashText source+      , iSource          = source+      , iFileType        = fileType+      , iImportedModules = mhs+      , iModuleName      = mname+      , iScope           = empty -- publicModules scope+      , iInsideScope     = topLevelScope topLevel+      , iSignature       = sig+      , iDisplayForms    = display+      , iUserWarnings    = userwarns+      , iImportWarning   = importwarn+      , iBuiltin         = builtin'+      , iForeignCode     = foreignCode+      , iHighlighting    = syntaxInfo+      , iDefaultPragmaOptions = defPragmas+      , iFilePragmaOptions    = filePragmas+      , iOptionsUsed     = optionsUsed+      , iPatternSyns     = patsyns+      , iWarnings        = warnings+      , iPartialDefs     = partialDefs+      }+    reportSLn "import.iface" 7 "  interface complete"+    return i++-- | Returns (iSourceHash, iFullHash)+--   We do not need to check that the file exist because we only+--   accept @InterfaceFile@ as an input and not arbitrary @AbsolutePath@!+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++moduleHash :: ModuleName -> TCM Hash+moduleHash m = iFullHash <$> getNonMainInterface (toTopLevelModuleName m) Nothing

src/full/Agda/Interaction/Imports.hs-boot view

@@ -1,20 +1,10 @@  module Agda.Interaction.Imports where -import Agda.Syntax.Abstract.Name    ( ModuleName )-import Agda.Syntax.Scope.Base       ( Scope )-import Agda.TypeChecking.Monad.Base ( TCM, TCWarning )-import Agda.TypeChecking.Warnings   ( WhichWarnings ) import Data.Map                     ( Map ) -data MaybeWarnings' a = NoWarnings | SomeWarnings a-type MaybeWarnings = MaybeWarnings' [TCWarning]-instance Functor MaybeWarnings'--data Mode-data MainInterface = MainInterface Mode | NotMainInterface--instance Eq MainInterface+import Agda.Syntax.Abstract.Name    ( ModuleName )+import Agda.Syntax.Scope.Base       ( Scope )+import Agda.TypeChecking.Monad.Base ( TCM )  scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)-getMaybeWarnings :: WhichWarnings -> TCM MaybeWarnings

src/full/Agda/Interaction/InteractionTop.hs view

@@ -1,5 +1,5 @@+{-# LANGUAGE NondecreasingIndentation #-} {-# OPTIONS_GHC -fno-cse #-}- {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.Interaction.InteractionTop@@ -14,6 +14,7 @@ import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar import qualified Control.Exception as E+import Control.Monad.Except import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State hiding (state)@@ -23,13 +24,14 @@ import Data.Function import qualified Data.List as List import qualified Data.Map as Map+import Data.Maybe  import System.Directory import System.FilePath -import Agda.TypeChecking.Monad as TM+import Agda.TypeChecking.Monad as TCM   hiding (initState, setCommandLineOptions)-import qualified Agda.TypeChecking.Monad as TM+import qualified Agda.TypeChecking.Monad as TCM import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Rules.Term (checkExpr, isType_) import Agda.TypeChecking.Errors@@ -40,6 +42,7 @@ import Agda.Syntax.Parser import Agda.Syntax.Common import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pretty import Agda.Syntax.Info (mkDefInfo)@@ -56,24 +59,15 @@ import Agda.Interaction.Response hiding (Function, ExtendedLambda) import qualified Agda.Interaction.Response as R import qualified Agda.Interaction.BasicOps as B-import Agda.Interaction.BasicOps hiding (whyInScope)-import Agda.Interaction.Highlighting.Precise hiding (Error, Postulate)+import Agda.Interaction.Highlighting.Precise hiding (Error, Postulate, singleton)+import Agda.Interaction.Imports  ( Mode, pattern ScopeCheck, pattern TypeCheck ) import qualified Agda.Interaction.Imports as Imp import Agda.Interaction.Highlighting.Generate-import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX -import Agda.Compiler.Common (IsMain (..)) import Agda.Compiler.Backend  import Agda.Auto.Auto as Auto -import Agda.Utils.Except-  ( ExceptT-  , mkExceptT-  , MonadError(catchError)-  , runExceptT-  )- import Agda.Utils.Either import Agda.Utils.FileName import Agda.Utils.Function@@ -82,7 +76,8 @@ import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Pretty hiding (Mode)+import Agda.Utils.Singleton import Agda.Utils.String import Agda.Utils.Time import Agda.Utils.Tuple@@ -133,7 +128,9 @@     return a  -- | Opposite of 'liftIO' for 'CommandM'.---   Use only if main errors are already catched.+--+-- This function should only be applied to computations that are+-- guaranteed not to raise any errors (except for 'IOException's).  commandMToIO :: (forall x . (CommandM a -> IO x) -> IO x) -> CommandM a commandMToIO ci_i = revLift runStateT lift $ \ct -> revLiftTC runSafeTCM liftIO $ ci_i . (. ct)@@ -206,7 +203,7 @@     -- Yet, it looks like s == s' in case the command failed.     cmd `catchErr` \ e -> do       onFail-      handleErr e+      handleErr Nothing e       -- Andreas, 2016-11-18, issue #2174       -- Reset TCState after error is handled, to get rid of metas created during failed command       lift $ do@@ -225,13 +222,14 @@       put s'       return x -    -- | Handle every possible kind of error (#637), except for+    -- Handle every possible kind of error (#637), except for     -- AsyncCancelled, which is used to abort Agda.     handleNastyErrors :: CommandM () -> CommandM ()     handleNastyErrors m = commandMToIO $ \ toIO -> do       let handle e =             Right <$>-              (toIO $ handleErr $ Exception noRange $ text $ show e)+              toIO (handleErr (Just Direct) $+                        Exception noRange $ text $ show e)            asyncHandler e@AsyncCancelled = return (Left e) @@ -243,31 +241,32 @@         Right x -> return x         Left e  -> E.throwIO e -    -- | Displays an error and instructs Emacs to jump to the site of the+    -- Displays an error and instructs Emacs to jump to the site of the     -- error. Because this function may switch the focus to another file     -- the status information is also updated.-    handleErr e = do-        unsolvedNotOK <- lift $ not . optAllowUnsolved <$> pragmaOptions-        meta    <- lift $ computeUnsolvedMetaWarnings-        constr  <- lift $ computeUnsolvedConstraints+    handleErr method e = do+        unsolved <- lift $ computeUnsolvedInfo         err     <- lift $ errorHighlighting e         modFile <- lift $ useTC stModuleToSource-        method  <- lift $ viewTC eHighlightingMethod-        let info = compress $ mconcat $+        method  <- case method of+          Nothing -> lift $ viewTC eHighlightingMethod+          Just m  -> return m+        let info = convert $ err <> unsolved                      -- Errors take precedence over unsolved things.-                     err : if unsolvedNotOK then [meta, constr] else []          -- TODO: make a better predicate for this         noError <- lift $ null <$> prettyError e -        x <- lift $ optShowImplicit <$> useTC stPragmaOptions+        showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions+        showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions         unless noError $ mapM_ putResponse $             [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] ++             tellEmacsToJumpToError (getRange e) ++             [ Resp_HighlightingInfo info KeepHighlighting                                     method modFile ] ++             [ Resp_Status $ Status { sChecked = False-                                   , sShowImplicitArguments = x+                                   , sShowImplicitArguments = showImpl+                                   , sShowIrrelevantArguments = showIrr                                    } ]  -- | Run an 'IOTCM' value, catch the exceptions, emit output@@ -283,18 +282,20 @@     -- Raises an error if the given file is not the one currently     -- loaded.     cf <- gets theCurrentFile-    when (not (independent cmd) && Just currentAbs /= (fst <$> cf)) $-        lift $ typeError $ GenericError "Error: First load the file."+    when (not (independent cmd) && Just currentAbs /= (currentFilePath <$> cf)) $ do+        let mode = TypeCheck+        cmd_load' current [] True mode $ \_ -> return ()      withCurrentFile $ interpret cmd      cf' <- gets theCurrentFile     when (updateInteractionPointsAfter cmd             &&-          Just currentAbs == (fst <$> cf')) $+          Just currentAbs == (currentFilePath <$> cf')) $ do         putResponse . Resp_InteractionPoints =<< gets theInteractionPoints    where+    inEmacs :: forall a. CommandM a -> CommandM a     inEmacs = liftCommandMT $ withEnv $ initEnv             { envHighlightingLevel  = highlighting             , envHighlightingMethod = highlightingMethod@@ -362,14 +363,12 @@           return (Command Nothing)   where -  -- | Returns if the currently executing command should be aborted.+  -- Returns if the currently executing command should be aborted.   -- The "abort number" is returned.    waitForAbort-    :: Integer-       -- ^ The number of the currently executing command.-    -> CommandQueue-       -- ^ The command queue.+    :: Integer       -- The number of the currently executing command.+    -> CommandQueue  -- The command queue.     -> IO Integer   waitForAbort n q = do     atomically $ do@@ -378,7 +377,7 @@         Just a' | n <= a' -> return a'         _                 -> retry -  -- | Removes every command for which the command number is at most+  -- Removes every command for which the command number is at most   -- the given number (the "abort number") from the command queue.   --   -- New commands could be added to the end of the queue while this@@ -421,7 +420,7 @@             atomically $ writeTVar abort (Just n)             readCommands n           _ -> do-            n' <- return (succ n)+            let n' = (succ n)             atomically $ writeTChan commands (n', c)             case c of               Done -> return ()@@ -463,6 +462,8 @@ updateInteractionPointsAfter Cmd_highlight{}                     = True updateInteractionPointsAfter ShowImplicitArgs{}                  = False updateInteractionPointsAfter ToggleImplicitArgs{}                = False+updateInteractionPointsAfter ShowIrrelevantArgs{}                = False+updateInteractionPointsAfter ToggleIrrelevantArgs{}              = False updateInteractionPointsAfter Cmd_give{}                          = True updateInteractionPointsAfter Cmd_refine{}                        = True updateInteractionPointsAfter Cmd_intro{}                         = True@@ -491,36 +492,39 @@ interpret :: Interaction -> CommandM ()  interpret (Cmd_load m argv) =-  cmd_load' m argv True Imp.TypeCheck $ \_ -> interpret Cmd_metas+  cmd_load' m argv True mode $ \_ -> interpret $ Cmd_metas AsIs+  where+  mode = TypeCheck  interpret (Cmd_compile backend file argv) =-  cmd_load' file argv (backend `elem` [LaTeX, QuickLaTeX])-            (if backend == QuickLaTeX-             then Imp.ScopeCheck-             else Imp.TypeCheck) $ \(i, mw) -> do-    mw' <- lift $ Imp.applyFlagsToMaybeWarnings mw-    case mw' of-      Imp.NoWarnings -> do+  cmd_load' file argv allowUnsolved mode $ \ checkResult -> do+    mw <- lift $ applyFlagsToTCWarnings $ crWarnings checkResult+    case mw of+      [] -> do         lift $ case backend of-          LaTeX                    -> LaTeX.generateLaTeX i-          QuickLaTeX               -> LaTeX.generateLaTeX i-          OtherBackend "GHCNoMain" -> callBackend "GHC" NotMain i   -- for backwards compatibility-          OtherBackend b           -> callBackend b IsMain  i-        display_info . Info_CompilationOk =<< lift getWarningsAndNonFatalErrors-      Imp.SomeWarnings w -> display_info $ Info_Error $ Info_CompilationError w+          LaTeX                    -> callBackend "LaTeX" IsMain checkResult+          QuickLaTeX               -> callBackend "LaTeX" IsMain checkResult+          OtherBackend "GHCNoMain" -> callBackend "GHC" NotMain checkResult   -- for backwards compatibility+          OtherBackend b           -> callBackend b IsMain checkResult+        display_info . Info_CompilationOk =<< lift B.getWarningsAndNonFatalErrors+      w@(_:_) -> display_info $ Info_Error $ Info_CompilationError w+  where+  allowUnsolved = backend `elem` [LaTeX, QuickLaTeX]+  mode | QuickLaTeX <- backend = ScopeCheck+       | otherwise             = TypeCheck  interpret Cmd_constraints =     display_info . Info_Constraints =<< lift B.getConstraints -interpret Cmd_metas = do-  ms <- lift B.getGoals-  display_info . Info_AllGoalsWarnings ms =<< lift getWarningsAndNonFatalErrors+interpret (Cmd_metas norm) = do+  ms <- lift $ B.getGoals' norm (max Simplified norm)+  display_info . Info_AllGoalsWarnings ms =<< lift B.getWarningsAndNonFatalErrors  interpret (Cmd_show_module_contents_toplevel norm s) =-  liftCommandMT B.atTopLevel $ showModuleContents norm noRange s+  atTopLevel $ showModuleContents norm noRange s  interpret (Cmd_search_about_toplevel norm s) =-  liftCommandMT B.atTopLevel $ searchAbout norm noRange s+  atTopLevel $ searchAbout norm noRange s  interpret (Cmd_solveAll norm)        = solveInstantiatedGoals norm Nothing interpret (Cmd_solveOne norm ii _ _) = solveInstantiatedGoals norm' (Just ii)@@ -539,13 +543,13 @@   display_info $ Info_InferredType state time expr  interpret (Cmd_compute_toplevel cmode s) = do-  (time, expr) <- parseAndDoAtToplevel action (computeWrapInput cmode s)+  (time, expr) <- parseAndDoAtToplevel action (B.computeWrapInput cmode s)   state <- get   display_info $ Info_NormalForm state cmode time expr     where     action = allowNonTerminatingReductions-           . (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)-           . B.evalInCurrent+           . (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@@ -567,36 +571,48 @@     opts { optPragmaOptions =              ps { optShowImplicit = not $ optShowImplicit ps } } +interpret (ShowIrrelevantArgs showIrr) = do+  opts <- lift commandLineOptions+  setCommandLineOpts $+    opts { optPragmaOptions =+             (optPragmaOptions opts) { optShowIrrelevant = showIrr } }++interpret ToggleIrrelevantArgs = do+  opts <- lift commandLineOptions+  let ps = optPragmaOptions opts+  setCommandLineOpts $+    opts { optPragmaOptions =+             ps { optShowIrrelevant = not $ optShowIrrelevant ps } }+ interpret (Cmd_load_highlighting_info source) = do   l <- asksTC envHighlightingLevel   when (l /= None) $ do     -- Make sure that the include directories have     -- been set.     setCommandLineOpts =<< lift commandLineOptions-     resp <- lift $ liftIO . tellToUpdateHighlighting =<< do-      ex <- liftIO $ doesFileExist source+      ex        <- liftIO $ doesFileExist source       absSource <- liftIO $ SourceFile <$> absolute source-      case ex of-        False -> return Nothing-        True  -> (do-          si <- Imp.sourceInfo absSource-          let m = Imp.siModuleName si-          checkModuleName m absSource Nothing-          mmi <- getVisitedModule m-          case mmi of-            Nothing -> return Nothing-            Just mi ->-              if hashText (Imp.siSource si) ==-                 iSourceHash (miInterface mi)-               then do-                modFile <- useTC stModuleToSource-                method  <- viewTC eHighlightingMethod-                return $ Just (iHighlighting $ miInterface mi, method, modFile)-               else-                return Nothing)-            `catchError`-          \_ -> return Nothing+      if ex+        then+           do+              src <- Imp.parseSource absSource+              let m = Imp.srcModuleName src+              checkModuleName m absSource Nothing+              mmi <- getVisitedModule m+              case mmi of+                Nothing -> return Nothing+                Just mi ->+                  if hashText (Imp.srcText src) == iSourceHash (miInterface mi)+                    then do+                      modFile <- useTC stModuleToSource+                      method  <- viewTC eHighlightingMethod+                      return $ Just (iHighlighting $ miInterface mi, method, modFile)+                    else+                      return Nothing+            `catchError` \_ -> return Nothing+        else+          return Nothing     mapM_ putResponse resp  interpret (Cmd_tokenHighlighting source remove) = do@@ -637,7 +653,7 @@         Left err -> display_info $ Info_Error err         Right _ -> return ()     try :: Info_Error -> TCM a -> ExceptT Info_Error TCM a-    try err m = mkExceptT $ do+    try err m = ExceptT $ do       (mapLeft (const err) <$> freshTCM m) `catchError` \ _ -> return (Left err)       -- freshTCM to avoid scope checking creating new interaction points @@ -680,7 +696,7 @@     -- Andreas, 2014-07-07: Remove the interaction points in one go.     modifyTheInteractionPoints (List.\\ (map fst sols))     case autoMessage res of-     Nothing  -> interpret Cmd_metas+     Nothing  -> interpret $ Cmd_metas AsIs      Just msg -> display_info $ Info_Auto msg    FunClauses cs -> do     case autoMessage res of@@ -708,7 +724,7 @@     modifyTheInteractionPoints (List.\\ concat solved)  interpret (Cmd_context norm ii _ _) =-  display_info . Info_Context ii =<< liftLocalState (getResponseContext norm ii)+  display_info . Info_Context ii =<< liftLocalState (B.getResponseContext norm ii)  interpret (Cmd_helper_function norm ii rng s) = do   -- Create type of application of new helper function that would solve the goal.@@ -729,7 +745,7 @@     term <- case goal of       OfType _ ty -> checkExpr expr =<< isType_ ty       _           -> __IMPOSSIBLE__-    nf <- normalForm norm term+    nf <- B.normalForm norm term     txt <- localTC (\ e -> e { envPrintMetasBare = True }) (TCP.prettyTCM nf)     return $ show txt   give_gen WithoutForce ii rng have ElaborateGive@@ -757,14 +773,14 @@     term <- case goal of       OfType _ ty -> checkExpr expr =<< isType_ ty       _           -> __IMPOSSIBLE__-    normalForm norm term+    B.normalForm norm term   cmd_goal_type_context_and (GoalAndElaboration term) norm ii rng s  interpret (Cmd_show_module_contents norm ii rng s) =   liftCommandMT (B.withInteractionId ii) $ showModuleContents norm rng s  interpret (Cmd_why_in_scope_toplevel s) =-  liftCommandMT B.atTopLevel $ whyInScope s+  atTopLevel $ whyInScope s  interpret (Cmd_why_in_scope ii _range s) =   liftCommandMT (B.withInteractionId ii) $ whyInScope s@@ -801,21 +817,20 @@     -- very dirty hack, string manipulation by dropping the function name     -- and replacing the last " = " with " -> ". It's important not to replace     -- the equal sign in named implicit with an arrow!-    extlam_dropName :: Bool -> CaseContext -> String -> String+    extlam_dropName :: UnicodeOrAscii -> CaseContext -> String -> String     extlam_dropName _ Nothing x = x-    extlam_dropName unicode Just{}  x+    extlam_dropName glyphMode Just{}  x         = unwords $ reverse $ replEquals $ reverse $ drop 1 $ words x       where-        replEquals ("=" : ws)-           | unicode   = "→" : ws-           | otherwise = "->" : ws+        arrow = render $ _arrow $ specialCharactersForGlyphs glyphMode+        replEquals ("=" : ws) = arrow : ws         replEquals (w   : ws) = w : replEquals ws         replEquals []         = []  interpret (Cmd_compute cmode ii rng s) = do   expr <- liftLocalState $ do-    e <- B.parseExprIn ii rng (computeWrapInput cmode s)-    B.withInteractionId ii $ applyWhen (computeIgnoreAbstract cmode) ignoreAbstractMode $ B.evalInCurrent e+    e <- B.parseExprIn ii rng $ B.computeWrapInput cmode s+    B.withInteractionId ii $ applyWhen (B.computeIgnoreAbstract cmode) ignoreAbstractMode $ B.evalInCurrent cmode e   display_info $ Info_GoalSpecific ii (Goal_NormalForm cmode expr)  interpret Cmd_show_version = display_info Info_Version@@ -848,15 +863,17 @@ -- encountered then the command @cmd r@ is executed, where @r@ is the -- result of 'Imp.typeCheckMain'. -cmd_load' :: FilePath -> [String]-          -> Bool      -- ^ Allow unsolved meta-variables?-          -> Imp.Mode  -- ^ Full type-checking, or only-                       --   scope-checking?-          -> ((Interface, Imp.MaybeWarnings) -> CommandM ())-          -> CommandM ()+cmd_load'+  :: FilePath  -- ^ File to load into interaction.+  -> [String]  -- ^ Arguments to Agda for loading this file+  -> Bool      -- ^ Allow unsolved meta-variables?+  -> Mode      -- ^ Full type-checking, or only scope-checking?+  -> (CheckResult -> CommandM a)+               -- ^ Continuation after successful loading.+  -> CommandM a cmd_load' file argv unsolvedOK mode cmd = do-    f <- liftIO $ SourceFile <$> absolute file-    ex <- liftIO $ doesFileExist $ filePath (srcFilePath f)+    fp <- liftIO $ absolute file+    ex <- liftIO $ doesFileExist $ filePath fp     unless ex $ typeError $ GenericError $       "The file " ++ file ++ " was not found." @@ -867,25 +884,13 @@      t <- liftIO $ getModificationTime file -    -- Parse the file.-    si <- lift (Imp.sourceInfo f)--    -- 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-    z <- liftIO $ runOptM $ parseBackendOptions backends argv opts0-    case z of-      Left err   -> lift $ typeError $ GenericError err-      Right (_, opts) -> do-        let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o}-            root     = projectRoot (srcFilePath f) (Imp.siModuleName si)-        lift $ TM.setCommandLineOptions' root $ mapPragmaOptions update opts-        displayStatus+    -- Update the status. Because the "current file" is not set the+    -- status is not "Checked".+    displayStatus      -- Reset the state, preserving options and decoded modules. Note     -- that if the include directories have changed, then the decoded-    -- modules are reset when cmd_load' is run by ioTCM.+    -- modules are reset by TCM.setCommandLineOptions' below.     lift resetState      -- Clear the info buffer to make room for information about which@@ -895,9 +900,32 @@     -- Remove any prior syntax highlighting.     putResponse (Resp_ClearHighlighting NotOnlyTokenBased) +    -- Parse the file.+    --+    -- Note that options are set below.+    src <- lift $ Imp.parseSource (SourceFile fp) -    ok <- lift $ Imp.typeCheckMain f mode si+    -- Store the warnings.+    warnings <- useTC stTCWarnings +    -- 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+    z <- runOptM $ parseBackendOptions backends argv opts0+    case z of+      Left err   -> lift $ typeError $ GenericError err+      Right (_, opts) -> do+        opts <- lift $ addTrustedExecutables opts+        let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o}+            root     = projectRoot fp $ Imp.srcModuleName src+        lift $ TCM.setCommandLineOptions' root $ mapPragmaOptions update opts++    -- Restore the warnings that were saved above.+    modifyTCLens stTCWarnings (++ warnings)++    ok <- lift $ Imp.typeCheckMain mode src+     -- The module type checked. If the file was not changed while the     -- type checker was running then the interaction points and the     -- "current file" are stored.@@ -905,7 +933,7 @@     when (t == t') $ do       is <- lift $ sortInteractionPoints =<< getInteractionPoints       modify $ \st -> st { theInteractionPoints = is-                         , theCurrentFile       = Just (srcFilePath f, t)+                         , theCurrentFile       = Just $ CurrentFile fp argv t                          }      cmd ok@@ -913,9 +941,15 @@ -- | Set 'envCurrentPath' to 'theCurrentFile', if any. withCurrentFile :: CommandM a -> CommandM a withCurrentFile m = do-  mfile <- fmap fst <$> gets theCurrentFile+  mfile <- gets $ fmap currentFilePath . theCurrentFile   localTC (\ e -> e { envCurrentPath = mfile }) m +atTopLevel :: CommandM a -> CommandM a+atTopLevel cmd = liftCommandMT B.atTopLevel cmd++---------------------------------------------------------------------------+-- Giving, refining.+ data GiveRefine = Give | Refine | Intro | ElaborateGive   deriving (Eq, Show) @@ -951,6 +985,9 @@     -- parse string and "give", obtaining an abstract expression     -- and newly created interaction points     (time, (ae, ae0, iis)) <- maybeTimed $ lift $ do+        -- Issue 3000: mark the current hole as solved before giving, to avoid confusing it with potential+        -- new interaction points introduced by the give.+        removeInteractionPoint ii         mis  <- getInteractionPoints         reportSLn "interaction.give" 30 $ "interaction points before = " ++ show mis         given <- B.parseExprIn ii rng s@@ -993,7 +1030,7 @@     putResponse $ Resp_GiveAction ii $ mkNewTxt literally ce     lift $ reportSLn "interaction.give" 30 $ "putResponse GiveAction passed"     -- display new goal set (if not measuring time)-    maybe (interpret Cmd_metas) (display_info . Info_Time) time+    maybe (interpret $ Cmd_metas AsIs) (display_info . Info_Time) time     lift $ reportSLn "interaction.give" 30 $ "interpret Cmd_metas passed"   where     -- Substitutes xs for x in ys.@@ -1006,14 +1043,14 @@  highlightExpr :: A.Expr -> TCM () highlightExpr e =-  localTC (\st -> st { envModuleNestingLevel = 0+  localTC (\st -> st { envImportPath         = []                      , envHighlightingLevel  = NonInteractive                      , envHighlightingMethod = Direct }) $     generateAndPrintSyntaxInfo decl Full True   where-    dummy = mkName_ (NameId 0 0) ("dummy" :: String)+    dummy = mkName_ (NameId 0 noModuleNameHash) ("dummy" :: String)     info  = mkDefInfo (nameConcrete dummy) noFixity' PublicAccess ConcreteDef (getRange e)-    decl  = A.Axiom NoFunSig info defaultArgInfo Nothing (qnameFromList [dummy]) e+    decl  = A.Axiom OtherDefName info defaultArgInfo Nothing (qnameFromList $ singleton dummy) e  -- | Sorts interaction points based on their ranges. @@ -1031,7 +1068,7 @@ cmd_goal_type_context_and :: GoalTypeAux -> Rewrite -> InteractionId -> Range ->                              String -> CommandM () cmd_goal_type_context_and aux norm ii _ _ = do-  ctx <- lift $ getResponseContext norm ii+  ctx <- lift $ B.getResponseContext norm ii   constr <- lift $ lookupInteractionId ii >>= B.getConstraintsMentioning norm   boundary <- lift $ B.getIPBoundary norm ii   display_info $ Info_GoalSpecific ii (Goal_GoalType norm aux ctx boundary constr)@@ -1049,16 +1086,15 @@  searchAbout :: Rewrite -> Range -> String -> CommandM () searchAbout norm rg names = do-  let trimmedNames = trim names-  unless (null trimmedNames) $ do-    hits <- lift $ B.atTopLevel $ findMentions norm rg trimmedNames+  unlessNull (trim names) $ \ trimmedNames -> do+    hits <- lift $ findMentions norm rg trimmedNames     display_info $ Info_SearchAbout hits trimmedNames  -- | Explain why something is in scope.  whyInScope :: String -> CommandM () whyInScope s = do-  Just (file, _) <- gets theCurrentFile+  Just (CurrentFile file _ _) <- gets theCurrentFile   let cwd = takeDirectory (filePath file)   (v, xs, ms) <- liftLocalState (B.whyInScope s)   display_info $ Info_WhyInScope s cwd v xs ms@@ -1067,7 +1103,7 @@  setCommandLineOpts :: CommandLineOptions -> CommandM () setCommandLineOpts opts = do-    lift $ TM.setCommandLineOptions opts+    lift $ TCM.setCommandLineOptions opts     displayStatus  @@ -1077,27 +1113,30 @@  status :: CommandM Status status = do-  cf <- gets theCurrentFile+  cf       <- gets theCurrentFile   showImpl <- lift showImplicitArguments+  showIrr  <- lift showIrrelevantArguments    -- Check if the file was successfully type checked, and has not   -- changed since. Note: This code does not check if any dependencies   -- have changed, and uses a time stamp to check for changes.   checked  <- lift $ case cf of     Nothing     -> return False-    Just (f, t) -> do+    Just (CurrentFile f _ t) -> do       t' <- liftIO $ getModificationTime $ filePath f-      case t == t' of-        False -> return False-        True  -> do-          mm <- lookupModuleFromSource f-          case mm of-            Nothing -> return False -- work-around for Issue1007-            Just m  -> maybe False (not . miWarnings) <$> getVisitedModule m+      if t == t'+        then+          do+            mm <- lookupModuleFromSource f+            case mm of+              Nothing -> return False -- work-around for Issue1007+              Just m  -> maybe False (null . miWarnings) <$> getVisitedModule m+        else+            return False -  return $ Status { sShowImplicitArguments = showImpl-                  , sChecked               = checked-                  }+  return $ Status { sShowImplicitArguments   = showImpl,+                    sShowIrrelevantArguments = showIrr,+                    sChecked                 = checked }  -- | Displays or updates status information. --@@ -1129,7 +1168,7 @@ parseAndDoAtToplevel cmd s = do   localStateCommandM $ do     e <- lift $ runPM $ parse exprParser s-    maybeTimed $ lift $ B.atTopLevel $ do+    maybeTimed $ atTopLevel $ lift $       cmd =<< concreteToAbstract_ e  maybeTimed :: CommandM a -> CommandM (Maybe CPUTime, a)

src/full/Agda/Interaction/JSON.hs view

@@ -11,7 +11,7 @@   -- , ToRep(..), rep   ) where -import Control.Monad ((>=>), (<=<), sequence, liftM2)+import Control.Monad ((>=>), (<=<)) import Data.Aeson import Data.Aeson.Types (Pair) import Data.Text (Text)@@ -23,7 +23,6 @@ -- import qualified Agda.Syntax.Concrete as C -- import qualified Agda.Syntax.Internal as I import Agda.TypeChecking.Monad-import Agda.TypeChecking.Pretty (PrettyTCM(..)) import Agda.Utils.Pretty import qualified Agda.Utils.FileName as File import qualified Agda.Utils.Maybe.Strict as Strict

src/full/Agda/Interaction/JSONTop.hs view

@@ -2,37 +2,38 @@     ( jsonREPL     ) where import Control.Monad.State-import Control.Monad  import Data.Aeson hiding (Result(..)) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Text as T+import qualified Data.Set as Set  import Agda.Interaction.AgdaTop import Agda.Interaction.Base-  (CommandState(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..))+  (CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..)) import qualified Agda.Interaction.BasicOps as B import Agda.Interaction.EmacsTop import Agda.Interaction.JSON import Agda.Interaction.Response as R import Agda.Interaction.Highlighting.JSON-import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pretty (prettyATop) import Agda.Syntax.Common import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Concrete.Name (NameInScope(..), Name)-import Agda.Syntax.Internal (telToList, Dom'(..), Dom)-import Agda.Syntax.Position (noRange, Range, rangeIntervals, Interval'(..), Position'(..))+import Agda.Syntax.Internal (telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..))+import Agda.Syntax.Position (Range, rangeIntervals, Interval'(..), Position'(..)) import Agda.VersionCommit -import Agda.TypeChecking.Monad (Comparison(..), inTopContext, ProblemId(..), TCM)-import Agda.TypeChecking.Monad.MetaVars (getInteractionRange)+import Agda.TypeChecking.Errors (getAllWarningsOfTCErr)+import Agda.TypeChecking.Monad (Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..))+import Agda.TypeChecking.Monad.MetaVars (getInteractionRange, getMetaRange) import Agda.TypeChecking.Pretty (PrettyTCM(..), prettyTCM) -- borrowed from EmacsTop, for temporarily serialising stuff-import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings, prettyTCWarnings')+import Agda.TypeChecking.Pretty.Warning (filterTCWarnings) import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors(..))-import Agda.Utils.Pretty (Pretty(..), render)+import Agda.Utils.Pretty (Pretty(..))+import qualified Agda.Utils.Pretty as P import Agda.Utils.Time (CPUTime(..))  --------------------------------------------------------------------------------@@ -53,8 +54,9 @@ instance EncodeTCM Status where instance ToJSON Status where   toJSON status = object-    [ "showImplicitArguments" .= sShowImplicitArguments status-    , "checked"               .= sChecked status+    [ "showImplicitArguments"   .= sShowImplicitArguments status+    , "showIrrelevantArguments" .= sShowIrrelevantArguments status+    , "checked"                 .= sChecked status     ]  instance EncodeTCM CommandState where@@ -65,11 +67,15 @@     -- more?     ] +instance EncodeTCM CurrentFile where+instance ToJSON CurrentFile where+  toJSON (CurrentFile path _ time) = toJSON (path, time)  -- backwards compat.+ instance EncodeTCM ResponseContextEntry where   encodeTCM entry = obj     [ "originalName" @= encodePretty (respOrigName entry)     , "reifiedName"  @= encodePretty (respReifName entry)-    , "binding"      #= encodePrettyTCM (respType entry)+    , "binding"      #= prettyATop (unArg (respType entry))     , "inScope"      @= respInScope entry     ] @@ -87,9 +93,11 @@     where prettyInterval i = object [ "start" .= iStart i, "end" .= iEnd i ]  instance EncodeTCM ProblemId where-instance ToJSON ProblemId where-  toJSON (ProblemId i) = toJSON i+instance EncodeTCM MetaId    where +instance ToJSON ProblemId where toJSON (ProblemId i) = toJSON i+instance ToJSON MetaId    where toJSON (MetaId    i) = toJSON i+ instance EncodeTCM InteractionId where   encodeTCM ii@(InteractionId i) = obj     [ "id"    @= toJSON i@@ -100,6 +108,15 @@ instance ToJSON InteractionId where   toJSON (InteractionId i) = toJSON i +instance EncodeTCM NamedMeta where+  encodeTCM m = obj+    [ "name"  #= nameTCM+    , "range" #= intervalsTCM+    ]+    where+      nameTCM = encodeShow <$> B.withMetaId (nmid m) (prettyATop m)+      intervalsTCM = toJSON <$> getMetaRange (nmid m)+ instance EncodeTCM GiveResult where instance ToJSON GiveResult where   toJSON (Give_String s) = object [ "str" .= s ]@@ -129,85 +146,90 @@ instance EncodeTCM ComputeMode where instance ToJSON ComputeMode where toJSON = encodeShow -encodeOCCmp :: (a -> Value)+encodeOCCmp :: (a -> TCM Value)   -> Comparison -> a -> a -> T.Text   -> TCM Value encodeOCCmp f c i j k = kind k   [ "comparison"     @= encodeShow c-  , "constraintObjs" @= map f [i, j]+  , "constraintObjs" #= traverse f [i, j]   ]    -- Goals-encodeOC :: (a -> Value)+encodeOC :: (a -> TCM Value)   -> (b -> TCM Value)   -> OutputConstraint b a   -> TCM Value-encodeOC f encodePrettyTCM = \case+encodeOC f encPrettyTCM = \case  OfType i a -> kind "OfType"-  [ "constraintObj" @= f i-  , "type"          #= encodePrettyTCM a+  [ "constraintObj" #= f i+  , "type"          #= encPrettyTCM a   ]  CmpInType c a i j -> kind "CmpInType"   [ "comparison"     @= encodeShow c-  , "type"           #= encodePrettyTCM a-  , "constraintObjs" @= map f [i, j]+  , "type"           #= encPrettyTCM a+  , "constraintObjs" #= traverse f [i, j]   ]  CmpElim ps a is js -> kind "CmpElim"   [ "polarities"     @= map encodeShow ps-  , "type"           #= encodePrettyTCM a-  , "constraintObjs" @= map (map f) [is, js]+  , "type"           #= encPrettyTCM a+  , "constraintObjs" #= traverse (traverse f) [is, js]   ]  JustType a -> kind "JustType"-  [ "constraintObj"  @= f a+  [ "constraintObj"  #= f a   ]  JustSort a -> kind "JustSort"-  [ "constraintObj"  @= f a+  [ "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"- Guard oc a -> kind "Guard"-  [ "constraint"     #= encodeOC f encodePrettyTCM oc-  , "problem"        @= a-  ]  Assign i a -> kind "Assign"-  [ "constraintObj"  @= f i-  , "value"          #= encodePrettyTCM a+  [ "constraintObj"  #= f i+  , "value"          #= encPrettyTCM a   ]  TypedAssign i v t -> kind "TypedAssign"-  [ "constraintObj"  @= f i-  , "value"          #= encodePrettyTCM v-  , "type"           #= encodePrettyTCM t+  [ "constraintObj"  #= f i+  , "value"          #= encPrettyTCM v+  , "type"           #= encPrettyTCM t   ]  PostponedCheckArgs i es t0 t1 -> kind "PostponedCheckArgs"-  [ "constraintObj"  @= f i-  , "ofType"         #= encodePrettyTCM t0-  , "arguments"      #= forM es encodePrettyTCM-  , "type"           #= encodePrettyTCM t1+  [ "constraintObj"  #= f i+  , "ofType"         #= encPrettyTCM t0+  , "arguments"      #= forM es encPrettyTCM+  , "type"           #= encPrettyTCM t1   ]  IsEmptyType a -> kind "IsEmptyType"-  [ "type"           #= encodePrettyTCM a+  [ "type"           #= encPrettyTCM a   ]  SizeLtSat a -> kind "SizeLtSat"-  [ "type"           #= encodePrettyTCM a+  [ "type"           #= encPrettyTCM a   ]  FindInstanceOF i t cs -> kind "FindInstanceOF"-  [ "constraintObj"  @= f i+  [ "constraintObj"  #= f i   , "candidates"     #= forM cs encodeKVPairs-  , "type"           #= encodePrettyTCM t+  , "type"           #= encPrettyTCM t   ]-  where encodeKVPairs (v, t) = obj-          [ "value"  #= encodePrettyTCM v-          , "type"   #= encodePrettyTCM t+  where encodeKVPairs (_, v, t) = obj -- TODO: encode kind+          [ "value"  #= encPrettyTCM v+          , "type"   #= encPrettyTCM t           ]  PTSInstance a b -> kind "PTSInstance"-  [ "constraintObjs" @= map f [a, b]+  [ "constraintObjs" #= traverse f [a, b]   ]- PostponedCheckFunDef name a -> kind "PostponedCheckFunDef"+ PostponedCheckFunDef name a err -> kind "PostponedCheckFunDef"   [ "name"           @= encodePretty name-  , "type"           #= encodePrettyTCM a+  , "type"           #= encPrettyTCM a+  , "error"          #= encodeTCM err   ]+ CheckLock t lk -> kind "CheckLock"+  [ "head"           #= f t+  , "lock"           #= f lk+  ]+ UsableAtMod mod t -> kind "UsableAtMod"+  [ "mod"           @= encodePretty mod+  , "term"          #= f t+  ]  encodeNamedPretty :: PrettyTCM a => (Name, a) -> TCM Value encodeNamedPretty (name, a) = obj@@ -216,32 +238,37 @@   ]  instance EncodeTCM (OutputForm C.Expr C.Expr) where-  encodeTCM (OutputForm range problems oc) = obj+  encodeTCM (OutputForm range problems unblock oc) = obj     [ "range"      @= range     , "problems"   @= problems-    , "constraint" #= encodeOC encodeShow (pure . encodeShow) oc+    , "unblocker"  @= unblock+    , "constraint" #= encodeOC (pure . encodeShow) (pure . encodeShow) oc     ] +instance EncodeTCM Blocker where+  encodeTCM (UnblockOnMeta x)    = kind "UnblockOnMeta" [ "meta" @= x ]+  encodeTCM (UnblockOnProblem p) = kind "UnblockOnProblem" [ "id" @= p ]+  encodeTCM (UnblockOnAll us)    = kind "UnblockOnAll" [ "blockers" @= Set.toList us ]+  encodeTCM (UnblockOnAny us)    = kind "UnblockOnAny" [ "blockers" @= Set.toList us ]+ instance EncodeTCM DisplayInfo where   encodeTCM (Info_CompilationOk wes) = kind "CompilationOk"-    [ "warnings"          #= prettyTCWarnings (tcWarnings wes)-    , "errors"            #= prettyTCWarnings (nonFatalErrors wes)+    [ "warnings"          #= encodeTCM (filterTCWarnings (tcWarnings wes))+    , "errors"            #= encodeTCM (filterTCWarnings (nonFatalErrors wes))     ]   encodeTCM (Info_Constraints constraints) = kind "Constraints"     [ "constraints"       #= forM constraints encodeTCM     ]   encodeTCM (Info_AllGoalsWarnings (vis, invis) wes) = kind "AllGoalsWarnings"-    [ "visibleGoals"      #= forM vis (encodeOC toJSON encodePrettyTCM)-    , "invisibleGoals"    #= forM invis (encodeOC encodePretty encodePrettyTCM)-    , "warnings"          #= prettyTCWarnings (tcWarnings wes)-    , "errors"            #= prettyTCWarnings (nonFatalErrors wes)+    [ "visibleGoals"      #= forM vis (encodeOC encodeTCM encodePrettyTCM)+    , "invisibleGoals"    #= forM invis (encodeOC encodeTCM encodePrettyTCM)+    , "warnings"          #= encodeTCM (filterTCWarnings (tcWarnings wes))+    , "errors"            #= encodeTCM (filterTCWarnings (nonFatalErrors wes))     ]   encodeTCM (Info_Time time) = kind "Time"     [ "time"              @= time     ]-  encodeTCM (Info_Error msg) = kind "Error"-    [ "message"           #= showInfoError msg-    ]+  encodeTCM (Info_Error err) = encodeTCM err   encodeTCM Info_Intro_NotFound = kind "IntroNotFound" []   encodeTCM (Info_Intro_ConstructorUnknown introductions) = kind "IntroConstructorUnknown"     [ "constructors"      @= map toJSON introductions@@ -330,6 +357,29 @@     ]   go (Goal_InferredType expr) = kind "InferredType"     [ "expr"        #= prettyATop expr+    ]++instance EncodeTCM Info_Error where+  encodeTCM (Info_GenericError err) = kind "Error"+    [ "warnings"          #= (getAllWarningsOfTCErr err+                            >>= encodeTCM . filterTCWarnings)+    , "error"             #= encodeTCM err+    ]+  encodeTCM err = kind "Error"+    [ "warnings"          @= ([] :: [String])+    , "error"             #= obj+      [ "message"           #= showInfoError err+      ]+    ]++instance EncodeTCM TCErr where+  encodeTCM err = obj+    [ "message"     #= encodePrettyTCM err+    ]++instance EncodeTCM TCWarning where+  encodeTCM w = obj+    [ "message"     #= (P.render <$> prettyTCM w)     ]  instance EncodeTCM Response where

src/full/Agda/Interaction/Library.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} -- | Library management. -- --   Sample use:@@ -21,25 +20,39 @@   ( findProjectRoot   , getDefaultLibraries   , getInstalledLibraries+  , getTrustedExecutables   , libraryIncludePaths+  , getAgdaLibFiles'+  , getPrimitiveLibDir   , LibName+  , AgdaLibFile(..)+  , ExeName   , LibM+  , mkLibM   , LibWarning(..)   , LibPositionInfo(..)   , libraryWarningName+  , ProjectConfig(..)   -- * Exported for testing   , VersionView(..), versionView, unVersionView   , findLib'   ) where +import Control.Arrow ( first , second )+import Control.Monad.Except+import Control.Monad.State import Control.Monad.Writer+ import Data.Char import Data.Data ( Data ) import Data.Either-import Data.Bifunctor ( first )-import Data.Foldable ( foldMap ) import Data.Function+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Maybe ( catMaybes, fromMaybe ) import qualified Data.List as List+import qualified Data.Text as T+ import System.Directory import System.FilePath import System.Environment@@ -49,9 +62,12 @@ import Agda.Interaction.Options.Warnings  import Agda.Utils.Environment-import Agda.Utils.Except ( ExceptT, MonadError(throwError) )+import Agda.Utils.FileName+import Agda.Utils.Functor ( (<&>) ) import Agda.Utils.IO ( catchIO ) import Agda.Utils.List+import Agda.Utils.List1 ( List1 )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty@@ -59,19 +75,13 @@  import Agda.Version +-- Paths_Agda.hs is in $(BUILD_DIR)/build/autogen/.+import Paths_Agda ( getDataFileName )+ ------------------------------------------------------------------------ -- * Types and Monads ------------------------------------------------------------------------ --data LibrariesFile = LibrariesFile-  { lfPath   :: FilePath-      -- ^ E.g. @~/.agda/libraries@.-  , lfExists :: Bool-       -- ^ The libraries file might not exist,-       --   but we may print its assumed location in error messages.-  } deriving (Show)- -- | Library names are structured into the base name and a suffix of version --   numbers, e.g. @mylib-1.2.3@.  The version suffix is optional. data VersionView = VersionView@@ -86,7 +96,7 @@ -- mkLibM :: [AgdaLibFile] -> LibErrorIO a -> LibM a mkLibM libs m = do-  (x, ews) <- liftIO $ runWriterT m+  (x, ews) <- lift $ lift $ runWriterT m   let (errs, warns) = partitionEithers ews   tell warns   unless (null errs) $ do@@ -95,59 +105,6 @@   return x  --------------------------------------------------------------------------- * Library warnings and errors----------------------------------------------------------------------------data LibPositionInfo = LibPositionInfo-  { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file-  , lineNumPos :: LineNumber     -- ^ Line number in @libraries@ file.-  , filePos    :: FilePath       -- ^ Library file-  }-  deriving (Show, Data)--data LibWarning = LibWarning LibPositionInfo LibWarning'-  deriving (Show, Data)--data LibError = LibError (Maybe LibPositionInfo) LibError'--libraryWarningName :: LibWarning -> WarningName-libraryWarningName (LibWarning c (UnknownField{})) = LibUnknownField_---- | Collected errors while processing library files.----data LibError'-  = LibNotFound LibrariesFile LibName-      -- ^ Raised when a library name could no successfully be resolved-      --   to an @.agda-lib@ file.-      ---  | AmbiguousLib LibName [AgdaLibFile]-      -- ^ Raised when a library name is defined in several @.agda-lib files@.-  | OtherError String-      -- ^ Generic error.-  deriving (Show)---- | Collects 'LibError's and 'LibWarning's.----type LibErrorIO = WriterT [Either LibError LibWarning] IO---- | Throws 'Doc' exceptions, still collects 'LibWarning's.-type LibM = ExceptT Doc (WriterT [LibWarning] IO)--warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m ()-warnings = tell . map Right---- UNUSED Liang-Ting Chen 2019-07-16---warning :: MonadWriter [Either LibError LibWarning] m => LibWarning -> m ()---warning = warnings . pure--raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m ()-raiseErrors' = tell . map (Left . (LibError Nothing))--raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m ()-raiseErrors = tell . map Left-------------------------------------------------------------------------- -- * Resources ------------------------------------------------------------------------ @@ -168,22 +125,42 @@         putStrLn $ "Warning: Environment variable AGDA_DIR points to non-existing directory " ++ show dir ++ ", using " ++ show d ++ " instead."         return d +-- | Returns the absolute default lib dir. This directory is used to+-- store the Primitive.agda file.+getPrimitiveLibDir :: IO FilePath+getPrimitiveLibDir = do+  libdir <- filePath <$> (absolute =<< getDataFileName "lib")+  ifM (doesDirectoryExist libdir)+      (return $ libdir </> "prim")+      (error $ "The lib directory " ++ libdir ++ " does not exist")+ -- | The @~/.agda/libraries@ file lists the libraries Agda should know about.---   The content of @libraries@ is is a list of pathes to @.agda-lib@ files.+--   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@. -- --   @defaultLibraryFiles@ gives a list of all @libraries@ files Agda should process --   by default. ---defaultLibraryFiles :: [FilePath]-defaultLibraryFiles = ["libraries-" ++ version, "libraries"]+defaultLibraryFiles :: List1 FilePath+defaultLibraryFiles = List1.fromList ["libraries-" ++ version, "libraries"]  -- | The @defaultsFile@ contains a list of library names relevant for each Agda project. -- defaultsFile :: FilePath defaultsFile = "defaults" +-- | The @~/.agda/executables@ file lists the executables Agda should know about.+--   The content of @executables@ is a list of paths to executables.+--+--   Agda honors also version specific @executables@ files, e.g. @executables-2.6.0@.+--+--   @defaultExecutablesFiles@ gives a list of all @executables@ Agda should process+--   by default.+--+defaultExecutableFiles :: List1 FilePath+defaultExecutableFiles = List1.fromList ["executables-" ++ version, "executables"]+ ------------------------------------------------------------------------ -- * Get the libraries for the current project ------------------------------------------------------------------------@@ -194,26 +171,62 @@  findProjectConfig   :: FilePath                          -- ^ Candidate (init: the directory Agda was called in)-  -> IO (Maybe (FilePath, [FilePath])) -- ^ Actual root and @.agda-lib@ files for this project-findProjectConfig root = do-  libs <- map (root </>) . filter ((== ".agda-lib") . takeExtension) <$> getDirectoryContents root-  case libs of-    []    -> do+  -> LibM ProjectConfig                -- ^ Actual root and @.agda-lib@ files for this project+findProjectConfig root = mkLibM [] $ findProjectConfig' root++findProjectConfig'+  :: FilePath                          -- ^ Candidate (init: the directory Agda was called in)+  -> LibErrorIO ProjectConfig          -- ^ Actual root and @.agda-lib@ files for this project+findProjectConfig' root = do+  getCachedProjectConfig root >>= \case+    Just conf -> return conf+    Nothing   -> do+      libFiles <- liftIO $ filter ((== ".agda-lib") . takeExtension) <$> getDirectoryContents root+      case libFiles of+        []     -> liftIO (upPath root) >>= \case+          Just up -> do+            conf <- findProjectConfig' up+            storeCachedProjectConfig root conf+            return conf+          Nothing -> return DefaultProjectConfig+        files -> do+          let conf = ProjectConfig root files+          storeCachedProjectConfig root conf+          return conf++  where+    -- Note that "going up" one directory is OS dependent+    -- if the directory is a symlink.+    --+    -- Quoting from https://hackage.haskell.org/package/directory-1.3.6.1/docs/System-Directory.html#v:canonicalizePath :+    --+    --   Note that on Windows parent directories .. are always fully+    --   expanded before the symbolic links, as consistent with the+    --   rest of the Windows API (such as GetFullPathName). In+    --   contrast, on POSIX systems parent directories .. are+    --   expanded alongside symbolic links from left to right. To+    --   put this more concretely: if L is a symbolic link for R/P,+    --   then on Windows L\.. refers to ., whereas on other+    --   operating systems L/.. refers to R.+    upPath :: FilePath -> IO (Maybe FilePath)+    upPath root = do       up <- canonicalizePath $ root </> ".."-      if up == root then return Nothing else findProjectConfig up-    files -> return (Just (root, files))+      if up == root then return Nothing else return $ Just up + -- | Get project root -findProjectRoot :: FilePath -> IO (Maybe FilePath)-findProjectRoot root = fmap fst <$> findProjectConfig root+findProjectRoot :: FilePath -> LibM (Maybe FilePath)+findProjectRoot root = findProjectConfig root <&> \case+  ProjectConfig p _    -> Just p+  DefaultProjectConfig -> Nothing --- | Get pathes of @.agda-lib@ files in given project root. -findAgdaLibFiles-  :: FilePath       -- ^ Project root.-  -> IO [FilePath]  -- ^ Pathes of @.agda-lib@ files for this project (if any).-findAgdaLibFiles root = fromMaybe [] . fmap snd <$> findProjectConfig root+-- | Get the contents of @.agda-lib@ files in the given project root.+getAgdaLibFiles' :: FilePath -> LibErrorIO [AgdaLibFile]+getAgdaLibFiles' path = findProjectConfig' path >>= \case+  DefaultProjectConfig    -> return []+  ProjectConfig root libs -> parseLibFiles Nothing $ map ((0,) . (root </>)) libs  -- | Get dependencies and include paths for given project root: --@@ -226,10 +239,10 @@   -> Bool      -- ^ Use @defaults@ if no @.agda-lib@ file exists for this project?   -> LibM ([LibName], [FilePath])  -- ^ The returned @LibName@s are all non-empty strings. getDefaultLibraries root optDefaultLibs = mkLibM [] $ do-  libs <- lift $ findAgdaLibFiles root+  libs <- getAgdaLibFiles' root   if null libs     then (,[]) <$> if optDefaultLibs then (libNameForCurrentDir :) <$> readDefaultsFile else return []-    else libsAndPaths <$> parseLibFiles Nothing (map (0,) libs)+    else return $ libsAndPaths libs   where     libsAndPaths ls = ( concatMap _libDepends ls                       , nubOn id (concatMap _libIncludes ls)@@ -241,10 +254,10 @@ -- readDefaultsFile :: LibErrorIO [LibName] readDefaultsFile = do-    agdaDir <- lift $ getAgdaAppDir+    agdaDir <- liftIO getAgdaAppDir     let file = agdaDir </> defaultsFile-    ifNotM (lift $ doesFileExist file) (return []) $ {-else-} do-      ls <- lift $ map snd . stripCommentLines <$> readFile file+    ifNotM (liftIO $ doesFileExist file) (return []) $ {-else-} do+      ls <- liftIO $ map snd . stripCommentLines <$> readFile file       return $ concatMap splitCommas ls   `catchIO` \ e -> do     raiseErrors' [ OtherError $ unlines ["Failed to read defaults file.", show e] ]@@ -259,17 +272,21 @@ --   Note: file may not exist. -- getLibrariesFile-  :: Maybe FilePath -- ^ Override the default @libraries@ file?-  -> IO LibrariesFile-getLibrariesFile (Just overrideLibFile) =-  return $ LibrariesFile overrideLibFile True  -- Existence checked in cmdline option parser.+  :: (MonadIO m, MonadError String m)+  => Maybe FilePath -- ^ Override the default @libraries@ file?+  -> m LibrariesFile+getLibrariesFile (Just overrideLibFile) = do+  -- A user-specified override file must exist.+  ifM (liftIO $ doesFileExist overrideLibFile)+    {-then-} (return $ LibrariesFile overrideLibFile True)+    {-else-} (throwError $ "Libraries file not found: " ++ overrideLibFile) getLibrariesFile Nothing = do-  agdaDir <- getAgdaAppDir-  let defaults = map (agdaDir </>) defaultLibraryFiles  -- NB: non-empty list-  files <- filterM doesFileExist defaults+  agdaDir <- liftIO $ getAgdaAppDir+  let defaults = List1.map (agdaDir </>) defaultLibraryFiles -- NB: very short list+  files <- liftIO $ filterM doesFileExist (List1.toList defaults)   case files of     file : _ -> return $ LibrariesFile file True-    []       -> return $ LibrariesFile (last defaults) False -- doesn't exist, but that's ok+    []       -> return $ LibrariesFile (List1.last defaults) False -- doesn't exist, but that's ok  -- | Parse the descriptions of the libraries Agda knows about. --@@ -279,11 +296,14 @@   :: Maybe FilePath     -- ^ Override the default @libraries@ file?   -> LibM [AgdaLibFile] -- ^ Content of library files.  (Might have empty @LibName@s.) getInstalledLibraries overrideLibFile = mkLibM [] $ do-    file <- lift $ getLibrariesFile overrideLibFile-    if not (lfExists file) then return [] else do-      ls    <- lift $ stripCommentLines <$> readFile (lfPath file)-      files <- lift $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- ls ]-      parseLibFiles (Just file) $ nubOn snd files+    filem <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile+    case filem of+      Left err -> raiseErrors' [OtherError err] >> return []+      Right file -> do+        if not (lfExists file) then return [] else do+          ls    <- liftIO $ stripCommentLines <$> readFile (lfPath file)+          files <- liftIO $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- ls ]+          parseLibFiles (Just file) $ nubOn snd files   `catchIO` \ e -> do     raiseErrors' [ OtherError $ unlines ["Failed to read installed libraries.", show e] ]     return []@@ -295,10 +315,22 @@   -> [(LineNumber, FilePath)]  -- ^ Library files paired with their line number in @libraries@.   -> LibErrorIO [AgdaLibFile]  -- ^ Content of library files.  (Might have empty @LibName@s.) parseLibFiles mlibFile files = do-  rs' <- lift $ mapM (parseLibFile . snd) files-  let ann (ln, fp) (e, ws) = (first (Just pos,) e, map (LibWarning pos) ws)-        where pos = LibPositionInfo (lfPath <$> mlibFile) ln fp-  let (xs, warns) = unzip $ zipWith ann files (map runP rs')++  anns <- forM files $ \(ln, file) -> do+    getCachedAgdaLibFile file >>= \case+      Just lib -> return (Right lib, [])+      Nothing  -> do+        (e, ws) <- liftIO $ runP <$> parseLibFile file+        let pos = LibPositionInfo (lfPath <$> mlibFile) ln file+            ws' = map (LibWarning (Just pos)) ws+        case e of+          Left err -> do+            return (Left (Just pos, err), ws')+          Right lib -> do+            storeCachedAgdaLibFile file lib+            return (Right lib, ws')++  let (xs, warns) = unzip anns       (errs, als) = partitionEithers xs    unless (null warns) $ warnings $ concat warns@@ -315,6 +347,67 @@     strip (i, s) = [ (i, s') | not $ null s' ]       where s' = trimLineComment s +-- | Returns the path of the @executables@ file which lists the trusted executables Agda knows about.+--+--   Note: file may not exist.+--+getExecutablesFile+  :: IO ExecutablesFile+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++-- | Return the trusted executables Agda knows about.+--+--   Returns none if there is no @executables@ file.+--+getTrustedExecutables+  :: LibM (Map ExeName FilePath)  -- ^ Content of @executables@ files.+getTrustedExecutables = mkLibM [] $ do+    file <- liftIO getExecutablesFile+    if not (efExists file) then return Map.empty else do+      es    <- liftIO $ stripCommentLines <$> readFile (efPath file)+      files <- liftIO $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- es ]+      tmp   <- parseExecutablesFile file $ nubOn snd files+      return tmp+  `catchIO` \ e -> do+    raiseErrors' [ OtherError $ unlines ["Failed to read trusted executables.", show e] ]+    return Map.empty++-- | Parse the @executables@ file.+--+parseExecutablesFile+  :: ExecutablesFile+  -> [(LineNumber, FilePath)]+  -> LibErrorIO (Map ExeName FilePath)+parseExecutablesFile ef files =+  fmap (Map.fromList . catMaybes) . forM files $ \(ln, fp) -> do++    -- Check if the executable exists.+    fpExists <- liftIO $ doesFileExist fp+    if not fpExists+      then do warnings' [ExeNotFound ef fp]+              return Nothing+      else do++      -- Check if the executable is executable.+      fpPerms <- liftIO $ getPermissions fp+      if not (executable fpPerms)+        then do warnings' [ExeNotExecutable ef fp]+                return Nothing+        else do++        -- Compute canonical executable name and absolute filepath.+        let strExeName  = takeFileName fp+        let strExeName' = fromMaybe strExeName $ stripExtension exeExtension strExeName+        let txtExeName  = T.pack strExeName'+        exePath <- liftIO $ makeAbsolute fp+        return $ Just (txtExeName, exePath)+ ------------------------------------------------------------------------ -- * Resolving library names to include pathes ------------------------------------------------------------------------@@ -326,18 +419,20 @@   -> [LibName]       -- ^ (Non-empty) library names to be resolved to (lists of) pathes.   -> LibM [FilePath] -- ^ Resolved pathes (no duplicates).  Contains "." if @[LibName]@ does. libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ WriterT $ do-    file <- getLibrariesFile overrideLibFile-    return $ runWriter $ (dot ++) . incs <$> find file [] xs+    efile <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile+    case efile of+      Left err -> return ([], [Left $ LibError Nothing $ OtherError err])+      Right file -> return $ runWriter $ (dot ++) . incs <$> find file [] xs   where     (dots, xs) = List.partition (== libNameForCurrentDir) $ map trim xs0     incs       = nubOn id . concatMap _libIncludes     dot        = [ "." | not $ null dots ] -    -- | Due to library dependencies, the work list may grow temporarily.+    -- Due to library dependencies, the work list may grow temporarily.     find-      :: LibrariesFile  -- ^ Only for error reporting.-      -> [LibName]      -- ^ Already resolved libraries.-      -> [LibName]      -- ^ Work list: libraries left to be resolved.+      :: LibrariesFile  -- Only for error reporting.+      -> [LibName]      -- Already resolved libraries.+      -> [LibName]      -- Work list: libraries left to be resolved.       -> Writer [Either LibError LibWarning] [AgdaLibFile]     find _ _ [] = pure []     find file visited (x : xs)@@ -421,51 +516,3 @@ unVersionView = \case   VersionView base [] -> base   VersionView base vs -> base ++ "-" ++ List.intercalate "." (map show vs)----------------------------------------------------------------------------- * Prettyprinting errors and warnings---------------------------------------------------------------------------formatLibPositionInfo :: LibPositionInfo -> String -> Doc-formatLibPositionInfo (LibPositionInfo libFile lineNum file) err = text $-  let loc | Just lf <- libFile = lf ++ ":" ++ show lineNum ++ ": "-          | otherwise = ""-  in if List.isPrefixOf "Failed to read" err-     then loc-     else file ++ ":" ++ (if all isDigit (take 1 err) then "" else " ")---- | Pretty-print 'LibError'.-formatLibError :: [AgdaLibFile] -> LibError -> Doc-formatLibError installed (LibError mc e) = prefix <+> body where-  prefix = case mc of-    Nothing                      -> ""-    Just c | OtherError err <- e -> formatLibPositionInfo c err-    _                            -> ""--  body = case e of-    LibNotFound file lib -> vcat $-      [ text $ "Library '" ++ lib ++ "' not found."-      , sep [ "Add the path to its .agda-lib file to"-            , nest 2 $ text $ "'" ++ lfPath file ++ "'"-            , "to install."-            ]-      , "Installed libraries:"-      ] ++-      map (nest 2)-         (if null installed then ["(none)"]-          else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ]-               | l <- installed ])--    AmbiguousLib lib tgts -> vcat $-      [ sep [ text $ "Ambiguous library '" ++ lib ++ "'."-            , "Could refer to any one of" ]-      ] ++ [ nest 2 $ text (_libName l) <+> parens (text $ _libFile l)-           | l <- tgts ]--    OtherError err -> text err--instance Pretty LibWarning where-  pretty (LibWarning c w) = formatLibPositionInfo c "" <+> pretty w--instance Pretty LibWarning' where-  pretty (UnknownField s) = text $ "Unknown field '" ++ s ++ "'"

src/full/Agda/Interaction/Library/Base.hs view

@@ -2,18 +2,71 @@  module Agda.Interaction.Library.Base where +import Control.Arrow ( first , second )+import Control.DeepSeq+import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Writer++import Data.Char ( isDigit )+import Data.Data ( Data )+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text ( Text )++import GHC.Generics (Generic)++import System.Directory+import System.FilePath++import Agda.Interaction.Options.Warnings++import Agda.Utils.FileName import Agda.Utils.Lens+import Agda.Utils.Pretty  -- | A symbolic library name. -- type LibName = String +data LibrariesFile = LibrariesFile+  { lfPath   :: FilePath+      -- ^ E.g. @~/.agda/libraries@.+  , lfExists :: Bool+       -- ^ The libraries file might not exist,+       --   but we may print its assumed location in error messages.+  } deriving (Show)++-- | A symbolic executable name.+--+type ExeName = Text++data ExecutablesFile = ExecutablesFile+  { efPath   :: FilePath+      -- ^ E.g. @~/.agda/executables@.+  , efExists :: Bool+       -- ^ The executables file might not exist,+       --   but we may print its assumed location in error messages.+  } deriving (Show, Data, Generic)+ -- | The special name @\".\"@ is used to indicated that the current directory --   should count as a project root. -- libNameForCurrentDir :: LibName libNameForCurrentDir = "." +-- | A file can either belong to a project located at a given root+--   containing one or more .agda-lib files, or be part of the default+--   project.+data ProjectConfig+  = ProjectConfig+    { configRoot         :: FilePath+    , configAgdaLibFiles :: [FilePath]+    }+  | DefaultProjectConfig+  deriving Generic+ -- | Content of a @.agda-lib@ file. -- data AgdaLibFile = AgdaLibFile@@ -21,8 +74,9 @@   , _libFile     :: FilePath    -- ^ Path to this @.agda-lib@ file (not content of the file).   , _libIncludes :: [FilePath]  -- ^ Roots where to look for the modules of the library.   , _libDepends  :: [LibName]   -- ^ Dependencies.+  , _libPragmas  :: [String]    -- ^ Default pragma options for all files in the library.   }-  deriving (Show)+  deriving (Show, Generic)  emptyLibFile :: AgdaLibFile emptyLibFile = AgdaLibFile@@ -30,6 +84,7 @@   , _libFile     = ""   , _libIncludes = []   , _libDepends  = []+  , _libPragmas  = []   }  -- | Lenses for AgdaLibFile@@ -45,3 +100,177 @@  libDepends :: Lens' [LibName] AgdaLibFile libDepends f a = f (_libDepends a) <&> \ x -> a { _libDepends = x }++libPragmas :: Lens' [String] AgdaLibFile+libPragmas f a = f (_libPragmas a) <&> \ x -> a { _libPragmas = x }+++------------------------------------------------------------------------+-- * Library warnings and errors+------------------------------------------------------------------------++type LineNumber = Int++data LibPositionInfo = LibPositionInfo+  { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file+  , lineNumPos :: LineNumber     -- ^ Line number in @libraries@ file.+  , filePos    :: FilePath       -- ^ Library file+  }+  deriving (Show, Data, Generic)++data LibWarning = LibWarning (Maybe LibPositionInfo) LibWarning'+  deriving (Show, Data, Generic)++-- | Library Warnings.+data LibWarning'+  = UnknownField String+  | ExeNotFound ExecutablesFile FilePath+      -- ^ Raised when a trusted executable can not be found.+  | ExeNotExecutable ExecutablesFile FilePath+      -- ^ Raised when a trusted executable does not have the executable permission.+  deriving (Show, Data, Generic)++data LibError = LibError (Maybe LibPositionInfo) LibError'++libraryWarningName :: LibWarning -> WarningName+libraryWarningName (LibWarning c (UnknownField{})) = LibUnknownField_+libraryWarningName (LibWarning c (ExeNotFound{})) = ExeNotFoundWarning_+libraryWarningName (LibWarning c (ExeNotExecutable{})) = ExeNotExecutableWarning_++-- | Collected errors while processing library files.+--+data LibError'+  = LibNotFound LibrariesFile LibName+      -- ^ Raised when a library name could not successfully be resolved+      --   to an @.agda-lib@ file.+      --+  | AmbiguousLib LibName [AgdaLibFile]+      -- ^ Raised when a library name is defined in several @.agda-lib files@.+  | OtherError String+      -- ^ Generic error.+  deriving (Show)++-- | Cache locations of project configurations and parsed .agda-lib files+type LibState =+  ( Map FilePath ProjectConfig+  , Map FilePath AgdaLibFile+  )++-- | Collects 'LibError's and 'LibWarning's.+--+type LibErrorIO = WriterT [Either LibError LibWarning] (StateT LibState IO)++-- | Throws 'Doc' exceptions, still collects 'LibWarning's.+type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO))++warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m ()+warnings = tell . map Right++warnings' :: MonadWriter [Either LibError LibWarning] m => [LibWarning'] -> m ()+warnings' = tell . map (Right . LibWarning Nothing)++-- UNUSED Liang-Ting Chen 2019-07-16+--warning :: MonadWriter [Either LibError LibWarning] m => LibWarning -> m ()+--warning = warnings . pure++raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m ()+raiseErrors' = tell . map (Left . (LibError Nothing))++raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m ()+raiseErrors = tell . map Left++getCachedProjectConfig+  :: (MonadState LibState m, MonadIO m)+  => FilePath -> m (Maybe ProjectConfig)+getCachedProjectConfig path = do+  path <- liftIO $ canonicalizePath path+  cache <- gets fst+  return $ Map.lookup path cache++storeCachedProjectConfig+  :: (MonadState LibState m, MonadIO m)+  => FilePath -> ProjectConfig -> m ()+storeCachedProjectConfig path conf = do+  path <- liftIO $ canonicalizePath path+  modify $ first $ Map.insert path conf++getCachedAgdaLibFile+  :: (MonadState LibState m, MonadIO m)+  => FilePath -> m (Maybe AgdaLibFile)+getCachedAgdaLibFile path = do+  path <- liftIO $ canonicalizePath path+  gets $ Map.lookup path . snd++storeCachedAgdaLibFile+  :: (MonadState LibState m, MonadIO m)+  => FilePath -> AgdaLibFile -> m ()+storeCachedAgdaLibFile path lib = do+  path <- liftIO $ canonicalizePath path+  modify $ second $ Map.insert path lib++------------------------------------------------------------------------+-- * Prettyprinting errors and warnings+------------------------------------------------------------------------++formatLibPositionInfo :: LibPositionInfo -> String -> Doc+formatLibPositionInfo (LibPositionInfo libFile lineNum file) err = text $+  let loc | Just lf <- libFile = lf ++ ":" ++ show lineNum ++ ": "+          | otherwise = ""+  in if "Failed to read" `List.isPrefixOf` err+     then loc+     else file ++ ":" ++ (if all isDigit (take 1 err) then "" else " ")++-- | Pretty-print 'LibError'.+formatLibError :: [AgdaLibFile] -> LibError -> Doc+formatLibError installed (LibError mc e) = prefix <+> body where+  prefix = case mc of+    Nothing                      -> ""+    Just c | OtherError err <- e -> formatLibPositionInfo c err+    _                            -> ""++  body = case e of+    LibNotFound file lib -> vcat $+      [ text $ "Library '" ++ lib ++ "' not found."+      , sep [ "Add the path to its .agda-lib file to"+            , nest 2 $ text $ "'" ++ lfPath file ++ "'"+            , "to install."+            ]+      , "Installed libraries:"+      ] +++      map (nest 2)+         (if null installed then ["(none)"]+          else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ]+               | l <- installed ])++    AmbiguousLib lib tgts -> vcat $+      sep [ text $ "Ambiguous library '" ++ lib ++ "'."+            , "Could refer to any one of"+          ]+        : [ nest 2 $ text (_libName l) <+> parens (text $ _libFile l) | l <- tgts ]+++    OtherError err -> text err++instance Pretty LibWarning where+  pretty (LibWarning mc w) = prefix <+> pretty w+    where+      prefix = case mc of+        Nothing -> ""+        Just c  -> formatLibPositionInfo c ""+++instance Pretty LibWarning' where+  pretty (UnknownField s) = text $ "Unknown field '" ++ s ++ "'"+  pretty (ExeNotFound file exe) = text $ "Executable '" ++ exe ++ "' not found."+  pretty (ExeNotExecutable file exe) = text $ "Executable '" ++ exe ++ "' not executable."++------------------------------------------------------------------------+-- NFData instances+------------------------------------------------------------------------++instance NFData ExecutablesFile+instance NFData ProjectConfig+instance NFData AgdaLibFile+instance NFData LibPositionInfo+instance NFData LibWarning+instance NFData LibWarning'

src/full/Agda/Interaction/Library/Parse.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} -- | Parser for @.agda-lib@ files. -- --   Example file:@@ -27,12 +26,11 @@   ( parseLibFile   , splitCommas   , trimLineComment-  , LineNumber   , runP-  , LibWarning'(..)   ) where  import Control.Monad+import Control.Monad.Except import Control.Monad.Writer import Data.Char import Data.Data@@ -42,7 +40,6 @@ import Agda.Interaction.Library.Base  import Agda.Utils.Applicative-import Agda.Utils.Except ( MonadError(throwError), ExceptT, runExceptT ) import Agda.Utils.IO ( catchIO ) import Agda.Utils.Lens import Agda.Utils.List   ( duplicates )@@ -55,11 +52,6 @@ runP :: P a -> (Either String a, [LibWarning']) runP = runWriter . runExceptT --- | Library Warnings.-data LibWarning'-  = UnknownField String-  deriving (Show, Data)- warningP :: LibWarning' -> P () warningP = tell . pure @@ -91,6 +83,7 @@   [ optionalField "name"    parseName                      libName   , optionalField "include" (pure . concatMap parsePaths)  libIncludes   , optionalField "depend"  (pure . concatMap splitCommas) libDepends+  , optionalField "flags"   (pure . concatMap parseFlags)  libPragmas   ]   where     parseName :: [String] -> P LibName@@ -106,6 +99,9 @@       go acc (       ' '  :cs) = fixup acc ++ go id cs       go acc (c           :cs) = go (acc . (c:)) cs +    parseFlags :: String -> [String]+    parseFlags = words+ -- | Parse @.agda-lib@ file. -- -- Sets 'libFile' name and turn mentioned include directories into absolute@@ -161,8 +157,8 @@       -- Plural s for error message.       s xs      = if length xs > 1 then "s" else ""       list xs   = List.intercalate ", " [ "'" ++ f ++ "'" | f <- xs ]-  when (not $ null missing) $ throwError $ "Missing field" ++ s missing ++ " " ++ list missing-  when (not $ null dup)     $ throwError $ "Duplicate field" ++ s dup ++ " " ++ list dup+  unless (null missing) $ throwError $ "Missing field" ++ s missing ++ " " ++ list missing+  unless (null dup)     $ throwError $ "Duplicate field" ++ s dup ++ " " ++ list dup  -- | Find 'Field' with given 'fName', throw error if unknown. findField :: String -> [Field] -> P (Maybe Field)@@ -179,9 +175,7 @@ -- @ parseGeneric :: String -> P GenericFile parseGeneric s =-  groupLines =<< concat <$> mapM (uncurry parseLine) (zip [1..] $ map stripComments $ lines s)--type LineNumber = Int+  groupLines =<< concat <$> zipWithM parseLine [1..] (map stripComments $ lines s)  -- | Lines with line numbers. data GenericLine@@ -231,7 +225,7 @@       -- 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 l r' | let r' = ltrim r, not (null r')]           []  -> throwError $ show l ++ ": Missing field name"           hs  -> throwError $ show l ++ ": Bad field name " ++ show h       _ -> throwError $ show l ++ ": Missing ':' for field " ++ show (ltrim s)@@ -260,8 +254,8 @@ -- | ...and trailing, but not leading, whitespace. stripComments :: String -> String stripComments "" = ""-stripComments ('-':'-':_) = ""-stripComments (c : s)     = cons c (stripComments s)+stripComments ('-':'-':c:_) | isSpace c = ""+stripComments (c : s) = cons c (stripComments s)   where     cons c "" | isSpace c = ""     cons c s = c : s

src/full/Agda/Interaction/MakeCase.hs view

@@ -2,16 +2,15 @@  module Agda.Interaction.MakeCase where -import Prelude hiding (mapM, mapM_, null)+import Prelude hiding (null) -import Control.Monad hiding (mapM, mapM_, forM)+import Control.Monad  import Data.Either-import qualified Data.Map as Map+import Data.Function import qualified Data.List as List import Data.Maybe import Data.Monoid-import Data.Traversable (mapM, forM)  import Agda.Syntax.Common import Agda.Syntax.Info@@ -35,16 +34,18 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Rules.Def (checkClauseLHS) import Agda.TypeChecking.Rules.LHS (LHSResult(..))-import Agda.TypeChecking.Rules.Term (isModuleFreeVar)+import Agda.TypeChecking.Rules.LHS.Problem (AsBinding(..))  import Agda.Interaction.Options import Agda.Interaction.BasicOps +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Null+import Agda.Utils.Pretty (prettyShow) import qualified Agda.Utils.Pretty as P import Agda.Utils.Size @@ -57,119 +58,144 @@  parseVariables   :: QName           -- ^ The function name.-  -> Telescope       -- ^ The telescope of the clause we are splitting.+  -> Context         -- ^ The context of the RHS of the clause we are splitting.+  -> [AsBinding]     -- ^ The as-bindings of the clause we are splitting   -> InteractionId   -- ^ The hole of this function we are working on.   -> Range           -- ^ The range of this hole.   -> [String]        -- ^ The words the user entered in this hole (variable names).   -> TCM [(Int,NameInScope)] -- ^ The computed de Bruijn indices of the variables to split on,                              --   with information about whether each variable is in scope.-parseVariables f tel ii rng ss = do+parseVariables f cxt asb ii rng ss = do +  -- We parse the variables in two steps:+  -- (1) Convert the strings given by the user to abstract names,+  --     using the scope information from the interaction meta.+  -- (2) Convert the abstract names to de Bruijn indices,+  --     using the context of the clause.+   -- Get into the context of the meta.   mId <- lookupInteractionId ii   updateMetaVarRange mId rng   mi  <- getMetaInfo <$> lookupMeta mId   enterClosure mi $ \ r -> do -    -- Get printed representation of variables in context.-    n  <- getContextSize-    xs <- forM (downFrom n) $ \ i -> do-      (,i) . P.render <$> prettyTCM (var i)+  reportSDoc "interaction.case" 20 $ do+    m   <- currentModule+    tel <- lookupSection m+    vcat+     [ "parseVariables:"+     , "current module  =" <+> prettyTCM m+     , "current section =" <+> inTopContext (prettyTCM tel)+     , "clause context  =" <+> prettyTCM (PrettyContext cxt)+     ] -    -- We might be under some lambdas, in which case the context-    -- is bigger than the number of pattern variables.-    let nPatVars = size tel-    let nlocals = n - nPatVars-    unless (nlocals >= 0) __IMPOSSIBLE__  -- cannot be negative+  -- Get printed representation of variables in context.  These are+  -- used for recognizing when the user wants to make a hidden+  -- variable (which is not in scope) visible.+  n  <- getContextSize+  xs <- forM (downFrom n) $ \ i ->+    (,) <$> (P.render <$> prettyTCM (var i)) <*> nameOfBV i -    fv <- getDefFreeVars f-    reportSDoc "interaction.case" 20 $ do-      m   <- currentModule-      tel <- lookupSection m-      cxt <- getContextTelescope-      vcat-       [ "parseVariables:"-       , "current module  =" <+> prettyTCM m-       , "current section =" <+> inTopContext (prettyTCM tel)-       , text $ "function's fvs  = " ++ show fv-       , text $ "number of locals= " ++ show nlocals-       , "context         =" <+> do inTopContext $ prettyTCM cxt-       , "checkpoints     =" <+> do (text . show) =<< asksTC envCheckpoints-       ]+  -- Step 1: From strings to abstract names+  abstractNames :: [(A.Name, Maybe BindingSource)] <- forM ss $ \s -> do -    -- Resolve each string to a variable.-    forM ss $ \ s -> do-      let failNotVar      = typeError $ GenericError $ "Not a variable: " ++ s-          failUnbound     = typeError $ GenericError $ "Unbound variable " ++ s-          failAmbiguous   = typeError $ GenericError $ "Ambiguous variable " ++ s-          failLocal       = typeError $ GenericError $-            "Cannot split on local variable " ++ s-          failModuleBound = typeError $ GenericError $-            "Cannot split on module parameter " ++ s-          failLetBound v  = typeError . GenericError $-            "Cannot split on let-bound variable " ++ s-          failInstantiatedVar v = typeError . GenericDocError =<< sep-              [ text $ "Cannot split on variable " ++ s ++ ", because it is bound to"-              , prettyTCM v-              ]-          failCaseLet     = typeError $ GenericError $-            "Cannot split on variable " ++ s ++-            ", because let-declarations may not be defined by pattern-matching"+    let cname = C.QName $ C.Name r C.InScope $ C.stringNameParts s+    -- Note: the range in the concrete name is only approximate.+    -- Jesper, 2018-12-19: Don't consider generalizable names since+    -- they can be shadowed by hidden variables.+    resolveName' (exceptKindsOfNames [GeneralizeName]) Nothing cname >>= \case -      let cname = C.QName $ C.Name r C.InScope $ C.stringNameParts s-      -- Note: the range in the concrete name is only approximate.-      -- Jesper, 2018-12-19: Don't consider generalizable names since-      -- they can be shadowed by hidden variables.-      resolveName' (exceptKindsOfNames [GeneralizeName]) Nothing cname >>= \case+      -- Fail if s is a name, but not of a variable.+      DefinedName{}       -> failNotVar s+      FieldName{}         -> failNotVar s+      ConstructorName{}   -> failNotVar s+      PatternSynResName{} -> failNotVar s -        -- Fail if s is a name, but not of a variable.-        DefinedName{}       -> failNotVar-        FieldName{}         -> failNotVar-        ConstructorName{}   -> failNotVar-        PatternSynResName{} -> failNotVar+      -- If s is a variable name, return it together with binding information.+      VarName x b -> return (x, Just b) -        -- If s is a variable name in scope, get its de Bruijn index-        -- via the type checker.-        VarName x b -> do-          (v, _) <- getVarInfo x-          case (v , b) of-            -- Slightly dangerous: the pattern variable `x` may be-            -- refined to the module parameter `var i`. But in this-            -- case the instantiation could as well be the other way-            -- around, so the new clauses will still make sense.-            (Var i [] , PatternBound) -> do-              reportSLn "interaction.case" 30 $ "resolved variable " ++ show x ++ " = " ++ show i-              when (i < nlocals) failCaseLet-              return (i - nlocals , C.InScope)-            (Var i [] , LambdaBound)-              | i < nlocals -> failLocal-              | otherwise   -> failModuleBound-            (Var i [] , LetBound) -> failLetBound v-            (_        , _       ) -> failInstantiatedVar v+      -- If s is not a name, compare it to the printed variable representation.+      UnknownName -> case (lookup s xs) of+        Nothing -> failUnbound s+        Just x  -> return (x, Nothing) -        -- If s is not a name, compare it to the printed variable representation.-        -- This fallback is to enable splitting on hidden variables.-        UnknownName -> do-          let xs' = filter ((s ==) . fst) xs-          when (null xs') $ failUnbound-          reportSLn "interaction.case" 20 $ "matching names corresponding to indices " ++ show xs'-          -- Andreas, 2018-05-28, issue #3095-          -- We want to act on an ambiguous name if it corresponds to only one local index.-          let xs'' = mapMaybe (\ (_,i) -> if i < nlocals then Nothing else Just $ i - nlocals) xs'-          when (null xs'') $ typeError $ GenericError $-            "Cannot make hidden lambda-bound variable " ++ s ++ " visible"-          -- Filter out variable bound by parent function or module.-          params <- moduleParamsToApply $ qnameModule f-          let isParam i = any ((== var i) . unArg) params-              xs'''     = filter (not . isParam) xs''-          when (null xs''') $ typeError $ GenericError $-            "Cannot make hidden module parameter " ++ s ++ " visible"-          case xs''' of-            []  -> failModuleBound-            [i] -> return (i , C.NotInScope)-            -- Issue 1325: Variable names in context can be ambiguous.-            _   -> failAmbiguous+  -- Step 2: Resolve each abstract name to a de Bruijn index. +  -- First, get context names of the clause.+  let clauseCxtNames = map (fst . unDom) cxt++  -- Valid names to split on are pattern variables of the clause,+  -- plus as-bindings that refer to a variable.+  let clauseVars = zip clauseCxtNames (map var [0..]) +++                   map (\(AsB name v _ _) -> (name,v)) asb++  -- We cannot split on module parameters or make them visible+  params <- moduleParamsToApply $ qnameModule f+  let isParam i = any ((== var i) . unArg) params++  forM (zip ss abstractNames) $ \(s, (name, bound)) -> case bound of+    -- Case 1: variable has a binding site. Check if it also exists in+    -- the clause context so we can split on it.+    Just bindingSource -> case (lookup name clauseVars, bindingSource) of+      -- Case 1a: it is also known in the clause telescope and is+      -- actually a variable. If a pattern variable (`PatternBound`)+      -- 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)+      -- Case 1b: the variable has been refined.+      (Just v         , PatternBound) -> failInstantiatedVar s v+      -- Case 1c: the variable is bound locally (e.g. a record let)+      (Nothing        , PatternBound) -> failCaseLet s+      -- Case 1d: module parameter+      (Just (Var i []), LambdaBound ) -> failModuleBound s+      -- Case 1e: locally lambda-bound variable+      (_              , LambdaBound ) -> failLocal s+      -- Case 1f: let-bound variable+      (_              , LetBound    ) -> failLetBound s+      -- Case 1g: with-bound variable (not used?)+      (_              , WithBound   ) -> __IMPOSSIBLE__+    -- Case 2: variable has no binding site, so we check if it can be+    -- made visible.+    Nothing -> case List.find (((==) `on` nameConcrete) name . fst) clauseVars of+      -- Case 2a: there is a variable with that concrete name in the+      -- 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)+      -- Case 2b: there is a variable with that concrete name, but it+      -- has been refined.+      Just (x, v) -> 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.+      Nothing -> failHiddenLocal s++  where++  failNotVar s      = typeError $ GenericError $ "Not a variable: " ++ s+  failUnbound s     = typeError $ GenericError $ "Unbound variable " ++ s+  failAmbiguous s   = typeError $ GenericError $ "Ambiguous variable " ++ s+  failLocal s       = typeError $ GenericError $+    "Cannot split on local variable " ++ s+  failHiddenLocal s = typeError $ GenericError $+    "Cannot make hidden lambda-bound variable " ++ s ++ " visible"+  failModuleBound s = typeError $ GenericError $+    "Cannot split on module parameter " ++ s+  failHiddenModuleBound s = typeError $ GenericError $+    "Cannot make hidden module parameter " ++ s ++ " visible"+  failLetBound s = typeError . GenericError $+    "Cannot split on let-bound variable " ++ s+  failInstantiatedVar s v = typeError . GenericDocError =<< sep+      [ text $ "Cannot split on variable " ++ s ++ ", because it is bound to"+      , prettyTCM v+      ]+  failCaseLet s     = typeError $ GenericError $+    "Cannot split on variable " ++ s +++    ", because let-declarations may not be defined by pattern-matching"+++ -- | Lookup the clause for an interaction point in the signature. --   Returns the CaseContext, the previous clauses, the clause itself, --   and a list of the remaining ones.@@ -195,20 +221,25 @@         ]       __IMPOSSIBLE__ -recheckAbstractClause :: Type -> Maybe Substitution -> A.SpineClause -> TCM Clause-recheckAbstractClause t sub cl = checkClauseLHS t sub cl $ \ lhs ->-  return Clause{ clauseLHSRange    = getRange cl-               , clauseFullRange   = getRange cl-               , clauseTel         = lhsVarTele lhs-               , namedClausePats   = lhsPatterns lhs-               , clauseBody        = Nothing -- We don't need the body for make case-               , clauseType        = Just (lhsBodyType lhs)-               , clauseCatchall    = False-               , clauseRecursive   = Nothing-               , clauseUnreachable = Nothing-               , clauseEllipsis    = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS cl-               }+recheckAbstractClause :: Type -> Maybe Substitution -> A.SpineClause -> TCM (Clause, Context, [AsBinding])+recheckAbstractClause t sub acl = checkClauseLHS t sub acl $ \ lhs -> do+  let cl = Clause{ clauseLHSRange    = getRange acl+                 , clauseFullRange   = getRange acl+                 , clauseTel         = lhsVarTele lhs+                 , namedClausePats   = lhsPatterns lhs+                 , clauseBody        = Nothing -- We don't need the body for make case+                 , clauseType        = Just (lhsBodyType lhs)+                 , clauseCatchall    = False+                 , clauseExact       = Nothing+                 , clauseRecursive   = Nothing+                 , clauseUnreachable = Nothing+                 , clauseEllipsis    = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl+                 }+  cxt <- getContext+  let asb = lhsAsBindings lhs+  return (cl, cxt, asb) + -- | Entry point for case splitting tactic.  makeCase :: InteractionId -> Range -> String -> TCM (QName, CaseContext, [A.Clause])@@ -219,7 +250,6 @@    -- Get function clause which contains the interaction point.   InteractionPoint { ipMeta = mm, ipClause = ipCl} <- lookupInteractionPoint hole-  let meta = fromMaybe __IMPOSSIBLE__ mm   (f, clauseNo, clTy, clWithSub, absCl@A.Clause{ clauseRHS = rhs }, clClos) <- case ipCl of     IPClause f i t sub cl clo _ -> return (f, i, t, sub, cl, clo)     IPNoClause                -> typeError $ GenericError $@@ -229,8 +259,9 @@   -- Instead of using the actual internal clause, we retype check the abstract clause (with   -- eMakeCase = True). This disables the forcing translation in the unifier, which allows us to   -- split on forced variables.-  clause <- enterClosure clClos $ \ _ -> locallyTC eMakeCase (const True) $-              recheckAbstractClause clTy clWithSub absCl+  (clause, clauseCxt, clauseAsBindings) <-+    enterClosure clClos $ \ _ -> locallyTC eMakeCase (const True) $+      recheckAbstractClause clTy clWithSub absCl    let (prevClauses, follClauses) = killRange (prevClauses0, follClauses0)     -- Andreas, 2019-08-08, issue #3966@@ -241,25 +272,36 @@       tel  = clauseTel  clause       ps   = namedClausePats clause       ell  = clauseEllipsis clause-  reportSDoc "interaction.case" 10 $ vcat+  reportSDoc "interaction.case" 100 $ vcat     [ "splitting clause:"     , nest 2 $ vcat-      [ "f       =" <+> prettyTCM f-      , "context =" <+> ((inTopContext . prettyTCM) =<< getContextTelescope)-      , "tel     =" <+> (inTopContext . prettyTCM) tel+      [ "f       =" <+> (text . show) f+      , "context =" <+> ((inTopContext . (text . show)) =<< getContextTelescope)+      , "tel     =" <+> (text . show) tel       , "perm    =" <+> text (show perm)-      , "ps      =" <+> prettyTCMPatternList ps-      , "ell     =" <+> text (show ell)+      , "ps      =" <+> (text . show) ps       ]     ]   reportSDoc "interaction.case" 60 $ vcat     [ "splitting clause:"     , nest 2 $ vcat-      [ "f       =" <+> (text . show) f-      , "context =" <+> ((inTopContext . (text . show)) =<< getContextTelescope)-      , "tel     =" <+> (text . show) tel+      [ "f       =" <+> pretty f+      , "context =" <+> ((inTopContext . pretty) =<< getContextTelescope)+      , "tel     =" <+> pretty tel+      , "perm    =" <+> (text . show) perm+      , "ps      =" <+> pretty ps+      ]+    ]+  reportSDoc "interaction.case" 10 $ vcat+    [ "splitting clause:"+    , nest 2 $ vcat+      [ "f       =" <+> prettyTCM f+      , "context =" <+> ((inTopContext . prettyTCM) =<< getContextTelescope)+      , "tel     =" <+> (inTopContext . prettyTCM) tel       , "perm    =" <+> text (show perm)-      , "ps      =" <+> (text . show) ps+      , "ps      =" <+> addContext tel (prettyTCMPatternList ps)+      , "ell     =" <+> text (show ell)+      , "type    =" <+> addContext tel (prettyTCM $ clauseType clause)       ]     ] @@ -320,10 +362,15 @@           -- mapM (snd <.> fixTarget) $ splitClauses cov           return cov     checkClauseIsClean ipCl-    (f, casectxt,) <$> mapM (makeAbstractClause f rhs ell) scs+    (f, casectxt,) <$> do+      -- Andreas, 2020-05-18, issue #4536+      -- 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     -- split on variables-    xs <- parseVariables f tel hole rng vars+    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@).@@ -335,7 +382,7 @@      -- If any of the split variables is hidden by the ellipsis, we     -- should force the expansion of the ellipsis.-    splitNames <- mapM nameOfBV toSplit+    let splitNames = map (\i -> fst $ unDom $ clauseCxt !! i) toSplit     shouldExpandEllipsis <- return (not $ null toShow) `or2M` anyEllipsisVar f absCl splitNames     let ell' | shouldExpandEllipsis = NoEllipsis              | otherwise            = ell@@ -411,7 +458,7 @@   -- In this case, we refuse to split, as this might lose the refinements.   checkClauseIsClean :: IPClause -> TCM ()   checkClauseIsClean ipCl = do-    sips <- filter ipSolved . Map.elems <$> useTC stInteractionPoints+    sips <- filter ipSolved . BiMap.elems <$> useTC stInteractionPoints     when (List.any ((== ipCl) . ipClause) sips) $       typeError $ GenericError $ "Cannot split as clause rhs has been refined.  Please reload" @@ -431,6 +478,15 @@       Arg (setOrigin CaseSplit ai) $ Named n $ VarP (PatternInfo PatOSplit []) $ SplitPatVar x i ls   mkVis np = np +-- | If a copattern split yields no clauses, we must be at an empty record type.+--   In this case, replace the rhs by @record{}@+makeRHSEmptyRecord :: A.RHS -> A.RHS+makeRHSEmptyRecord = \case+  A.RHS{}            -> A.RHS{ rhsExpr = A.Rec empty empty, rhsConcrete = Nothing }+  rhs@A.RewriteRHS{} -> rhs{ A.rewriteRHS = makeRHSEmptyRecord $ A.rewriteRHS rhs }+  A.AbsurdRHS        -> __IMPOSSIBLE__+  A.WithRHS{}        -> __IMPOSSIBLE__+ -- | Make clause with no rhs (because of absurd match).  makeAbsurdClause :: QName -> ExpandedEllipsis -> SplitClause -> TCM A.Clause@@ -450,10 +506,8 @@     -- Contract implicit record patterns before printing.     -- c <- translateRecordPatterns $ Clause noRange tel perm ps NoBody t False     -- Jesper, 2015-09-19 Don't contract, since we do on-demand splitting-    let c = Clause noRange noRange tel ps Nothing (argFromDom <$> t) False Nothing Nothing ell-    -- Normalise the dot patterns-    ps <- addContext tel $ normalise $ namedClausePats c-    reportSDoc "interaction.case" 60 $ "normalized patterns: " <+> prettyTCMPatternList ps+    let c = Clause noRange noRange tel ps Nothing (argFromDom <$> t) False Nothing Nothing Nothing ell+    let ps = namedClausePats c     inTopContext $ reify $ QNamed f $ c { namedClausePats = ps }

src/full/Agda/Interaction/Monad.hs view

@@ -1,12 +1,47 @@-module Agda.Interaction.Monad (IM, runIM, readline) where+{-# OPTIONS_GHC -fwarn-orphans #-}+{-# LANGUAGE CPP               #-} -import Control.Monad.Trans-import System.Console.Haskeline+module Agda.Interaction.Monad+  ( IM+  , runIM+  , readline+  ) where  import Agda.TypeChecking.Monad+  ( HasOptions+  , MonadTCEnv+  , MonadTCM+  , MonadTCState+  , ReadTCState+  , TCErr+  , TCM, TCMT(..)+  , mapTCMT+  )+import Control.Exception (throwIO)+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++-- | Interaction monad.+newtype IM a = IM {unIM :: TCMT (Haskeline.InputT IO) a}+  deriving+  ( Functor, Applicative, Monad, MonadIO+  , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM )++runIM :: IM a -> TCM a+runIM = mapTCMT (Haskeline.runInputT Haskeline.defaultSettings) . unIM++instance MonadError TCErr IM where+  throwError                = liftIO . throwIO+  catchError (IM (TCM m)) h = IM . TCM $ \s e ->+    m s e `Haskeline.catch` \err -> unTCM (unIM (h err)) s e+ -- | Line reader. The line reader history is not stored between -- sessions.- readline :: String -> IM (Maybe String)-readline s = lift (getInputLine s)+readline s = IM $ lift (Haskeline.getInputLine s)

src/full/Agda/Interaction/Options.hs view

@@ -1,1173 +1,7 @@-{-# LANGUAGE CPP       #-}-{-# LANGUAGE DataKinds #-}--module Agda.Interaction.Options-    ( CommandLineOptions(..)-    , PragmaOptions(..)-    , OptionsPragma-    , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)-    , Verbosity, VerboseKey, VerboseLevel-    , HtmlHighlight(..)-    , WarningMode(..)-    , checkOpts-    , parsePragmaOptions-    , parsePluginOptions-    , stripRTS-    , defaultOptions-    , defaultInteractionOptions-    , defaultVerbosity-    , defaultCutOff-    , defaultPragmaOptions-    , standardOptions_-    , unsafePragmaOptions-    , restartOptions-    , infectiveOptions-    , coinfectiveOptions-    , safeFlag-    , mapFlag-    , usage-    , defaultLibDir-    -- Reused by PandocAgda-    , inputFlag-    , standardOptions, deadStandardOptions-    , getOptSimple-    ) where--import Control.Monad            ( when )-import Control.Monad.Trans--import Data.IORef-import Data.Function-import Data.Maybe-import Data.List                ( intercalate )-import qualified Data.Set as Set--import System.Console.GetOpt    ( getOpt', usageInfo, ArgOrder(ReturnInOrder)-                                , OptDescr(..), ArgDescr(..)-                                )-import System.Directory         ( doesFileExist, doesDirectoryExist )--import Text.EditDistance--import Agda.Termination.CutOff  ( CutOff(..) )--import Agda.Interaction.Library-import Agda.Interaction.Options.Help-import Agda.Interaction.Options.IORefs-import Agda.Interaction.Options.Warnings--import Agda.Utils.Except-  ( ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )--import Agda.Utils.FileName      ( absolute, AbsolutePath, filePath )-import Agda.Utils.Functor       ( (<&>) )-import Agda.Utils.Lens          ( Lens', over )-import Agda.Utils.List          ( groupOn, wordsBy )-import Agda.Utils.Monad         ( ifM, readM )-import Agda.Utils.Trie          ( Trie )-import qualified Agda.Utils.Trie as Trie-import Agda.Utils.WithDefault--import Agda.Version--- Paths_Agda.hs is in $(BUILD_DIR)/build/autogen/.-import Paths_Agda ( getDataFileName )---- OptDescr is a Functor ----------------------------------------------------type VerboseKey   = String-type VerboseLevel = Int-type Verbosity    = Trie VerboseKey VerboseLevel--data HtmlHighlight = HighlightAll | HighlightCode | HighlightAuto-  deriving (Show, Eq)---- Don't forget to update---   doc/user-manual/tools/command-line-options.rst--- if you make changes to the command-line options!--data CommandLineOptions = Options-  { optProgramName      :: String-  , optInputFile        :: Maybe FilePath-  , optIncludePaths     :: [FilePath]-  , optAbsoluteIncludePaths :: [AbsolutePath]-  , optLibraries        :: [LibName]-  , optOverrideLibrariesFile :: Maybe FilePath-  -- ^ Use this (if Just) instead of .agda/libraries-  , optDefaultLibs      :: Bool-  -- ^ Use ~/.agda/defaults-  , optUseLibs          :: Bool-  -- ^ look for .agda-lib files-  , optShowVersion      :: Bool-  , optShowHelp         :: Maybe Help-  , optInteractive      :: Bool-  , optGHCiInteraction  :: Bool-  , optJSONInteraction  :: Bool-  , optOptimSmashing    :: Bool-  , optCompileDir       :: Maybe FilePath-  -- ^ In the absence of a path the project root is used.-  , optGenerateVimFile  :: Bool-  , optGenerateLaTeX    :: Bool-  , optGenerateHTML     :: Bool-  , optHTMLHighlight    :: HtmlHighlight-  , optDependencyGraph  :: Maybe FilePath-  , optLaTeXDir         :: FilePath-  , optHTMLDir          :: FilePath-  , optCSSFile          :: Maybe FilePath-  , optIgnoreInterfaces :: Bool-  , optIgnoreAllInterfaces :: Bool-  , optLocalInterfaces     :: Bool-  , optPragmaOptions    :: PragmaOptions-  , optOnlyScopeChecking :: Bool-    -- ^ Should the top-level module only be scope-checked, and not-    --   type-checked?-  , optWithCompiler     :: Maybe FilePath-    -- ^ Use the compiler at PATH instead of ghc / js / etc.-  }-  deriving Show---- | Options which can be set in a pragma.--data PragmaOptions = PragmaOptions-  { optShowImplicit              :: Bool-  , optShowIrrelevant            :: Bool-  , optUseUnicode                :: Bool-  , optVerbose                   :: Verbosity-  , optProp                      :: Bool-  , optAllowUnsolved             :: Bool-  , optAllowIncompleteMatch      :: Bool-  , optDisablePositivity         :: Bool-  , optTerminationCheck          :: Bool-  , optTerminationDepth          :: CutOff-    -- ^ Cut off structural order comparison at some depth in termination checker?-  , optCompletenessCheck         :: Bool-  , optUniverseCheck             :: Bool-  , optOmegaInOmega              :: Bool-  , optSubtyping                 :: WithDefault 'False-  , optCumulativity              :: Bool-  , optSizedTypes                :: WithDefault 'True-  , optGuardedness               :: WithDefault 'True-  , optInjectiveTypeConstructors :: Bool-  , optUniversePolymorphism      :: Bool-  , optIrrelevantProjections     :: Bool-  , optExperimentalIrrelevance   :: Bool  -- ^ irrelevant levels, irrelevant data matching-  , optWithoutK                  :: WithDefault 'False-  , optCopatterns                :: Bool  -- ^ Allow definitions by copattern matching?-  , optPatternMatching           :: Bool  -- ^ Is pattern matching allowed in the current file?-  , optExactSplit                :: Bool-  , optEta                       :: Bool-  , optForcing                   :: Bool  -- ^ Perform the forcing analysis on data constructors?-  , optProjectionLike            :: Bool  -- ^ Perform the projection-likeness analysis on functions?-  , optRewriting                 :: Bool  -- ^ Can rewrite rules be added and used?-  , optCubical                   :: Bool-  , optPostfixProjections        :: Bool-      -- ^ Should system generated projections 'ProjSystem' be printed-      --   postfix (True) or prefix (False).-  , optKeepPatternVariables      :: Bool-      -- ^ Should case splitting replace variables with dot patterns-      --   (False) or keep them as variables (True).-  , optInstanceSearchDepth       :: Int-  , optOverlappingInstances      :: Bool-  , optInversionMaxDepth         :: Int-  , optSafe                      :: Bool-  , optDoubleCheck               :: Bool-  , optSyntacticEquality         :: Bool  -- ^ Should conversion checker use syntactic equality shortcut?-  , optCompareSorts              :: Bool  -- ^ Should conversion checker compare sorts of types?-  , optWarningMode               :: WarningMode-  , optCompileNoMain             :: Bool-  , optCaching                   :: Bool-  , optCountClusters             :: Bool-    -- ^ Count extended grapheme clusters rather than code points when-    -- generating LaTeX.-  , optAutoInline                :: Bool-    -- ^ Automatic compile-time inlining for simple definitions (unless marked-    --   NOINLINE).-  , optPrintPatternSynonyms      :: Bool-  , optFastReduce                :: Bool-    -- ^ Use the Agda abstract machine (fastReduce)?-  , optConfluenceCheck           :: Bool-    -- ^ Check confluence of rewrite rules?-  , optFlatSplit                 :: Bool-     -- ^ Can we split on a (x :{flat} A) argument?-  }-  deriving (Show, Eq)---- | The options from an @OPTIONS@ pragma.------ In the future it might be nice to switch to a more structured--- representation. Note that, currently, there is not a one-to-one--- correspondence between list elements and options.-type OptionsPragma = [String]---- | 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--defaultVerbosity :: Verbosity-defaultVerbosity = Trie.singleton [] 1--defaultInteractionOptions :: PragmaOptions-defaultInteractionOptions = defaultPragmaOptions--defaultOptions :: CommandLineOptions-defaultOptions = Options-  { optProgramName      = "agda"-  , optInputFile        = Nothing-  , optIncludePaths     = []-  , optAbsoluteIncludePaths = []-  , optLibraries        = []-  , optOverrideLibrariesFile = Nothing-  , optDefaultLibs      = True-  , optUseLibs          = True-  , optShowVersion      = False-  , optShowHelp         = Nothing-  , optInteractive      = False-  , optGHCiInteraction  = False-  , optJSONInteraction  = False-  , optOptimSmashing    = True-  , optCompileDir       = Nothing-  , optGenerateVimFile  = False-  , optGenerateLaTeX    = False-  , optGenerateHTML     = False-  , optHTMLHighlight    = HighlightAll-  , optDependencyGraph  = Nothing-  , optLaTeXDir         = defaultLaTeXDir-  , optHTMLDir          = defaultHTMLDir-  , optCSSFile          = Nothing-  , optIgnoreInterfaces = False-  , optIgnoreAllInterfaces = False-  , optLocalInterfaces     = False-  , optPragmaOptions    = defaultPragmaOptions-  , optOnlyScopeChecking = False-  , optWithCompiler      = Nothing-  }--defaultPragmaOptions :: PragmaOptions-defaultPragmaOptions = PragmaOptions-  { optShowImplicit              = False-  , optShowIrrelevant            = False-  , optUseUnicode                = True-  , optVerbose                   = defaultVerbosity-  , optProp                      = False-  , optExperimentalIrrelevance   = False-  , optIrrelevantProjections     = False -- off by default in > 2.5.4, see issue #2170-  , optAllowUnsolved             = False-  , optAllowIncompleteMatch      = False-  , optDisablePositivity         = False-  , optTerminationCheck          = True-  , optTerminationDepth          = defaultCutOff-  , optCompletenessCheck         = True-  , optUniverseCheck             = True-  , optOmegaInOmega              = False-  , optSubtyping                 = Default-  , optCumulativity              = False-  , optSizedTypes                = Default-  , optGuardedness               = Default-  , optInjectiveTypeConstructors = False-  , optUniversePolymorphism      = True-  , optWithoutK                  = Default-  , optCopatterns                = True-  , optPatternMatching           = True-  , optExactSplit                = False-  , optEta                       = True-  , optForcing                   = True-  , optProjectionLike            = True-  , optRewriting                 = False-  , optCubical                   = False-  , optPostfixProjections        = False-  , optKeepPatternVariables      = False-  , optInstanceSearchDepth       = 500-  , optOverlappingInstances      = False-  , optInversionMaxDepth         = 50-  , optSafe                      = False-  , optDoubleCheck               = False-  , optSyntacticEquality         = True-  , optCompareSorts              = True-  , optWarningMode               = defaultWarningMode-  , optCompileNoMain             = False-  , optCaching                   = True-  , optCountClusters             = False-  , optAutoInline                = True-  , optPrintPatternSynonyms      = True-  , optFastReduce                = True-  , optConfluenceCheck           = False-  , optFlatSplit                 = True-  }---- | The default termination depth.--defaultCutOff :: CutOff-defaultCutOff = CutOff 0 -- minimum value---- | The default output directory for LaTeX.--defaultLaTeXDir :: String-defaultLaTeXDir = "latex"---- | The default output directory for HTML.--defaultHTMLDir :: String-defaultHTMLDir = "html"--type OptM = ExceptT String IO--runOptM :: OptM a -> IO (Either String a)-runOptM = runExceptT--{- | @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---- | Checks that the given options are consistent.--checkOpts :: Flag CommandLineOptions-checkOpts opts-  | htmlRelated = throwError htmlRelatedMessage-  | not (matches [optGHCiInteraction, optJSONInteraction, isJust . optInputFile] <= 1) =-      throwError "Choose at most one: input file, --interactive, or --interaction-json.\n"-  | or [ p opts && matches ps > 1 | (p, ps) <- exclusive ] =-      throwError exclusiveMessage-  | otherwise = return opts-  where-  matches = length . filter ($ opts)-  optionChanged opt = ((/=) `on` opt) opts defaultOptions--  atMostOne =-    [ optGenerateHTML-    , isJust . optDependencyGraph-    ] ++-    map fst exclusive--  exclusive =-    [ ( optOnlyScopeChecking-      , optGenerateVimFile :-        atMostOne-      )-    , ( optInteractive-      , optGenerateLaTeX : atMostOne-      )-    , ( optGHCiInteraction-      , optGenerateLaTeX : atMostOne-      )-    , ( optJSONInteraction-      , optGenerateLaTeX : atMostOne-      )-    ]--  exclusiveMessage = unlines $-    [ "The options --interactive, --interaction, --interaction-json and"-    , "--only-scope-checking cannot be combined with each other or"-    , "with --html or --dependency-graph. Furthermore"-    , "--interactive and --interaction cannot be combined with"-    , "--latex, and --only-scope-checking cannot be combined with"-    , "--vim."-    ]--  htmlRelated = not (optGenerateHTML opts) &&-    (  optionChanged optHTMLDir-    || optionChanged optHTMLHighlight-    || optionChanged optCSSFile-    )--  htmlRelatedMessage = unlines $-    [ "The options --html-highlight, --css-dir and --html-dir"-    , "only be used along with --html flag."-    ]---- | 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"                      | optDisablePositivity opts         ] ++-  [ "--no-termination-check"                     | not (optTerminationCheck opts)    ] ++-  [ "--type-in-type"                             | not (optUniverseCheck opts)       ] ++-  [ "--omega-in-omega"                           | optOmegaInOmega opts              ] ++--- [ "--sized-types"                              | optSizedTypes opts                ] ++-  [ "--sized-types and --guardedness"            | collapseDefault (optSizedTypes opts)-                                                 , collapseDefault (optGuardedness opts) ] ++-  [ "--injective-type-constructors"              | optInjectiveTypeConstructors opts ] ++-  [ "--irrelevant-projections"                   | optIrrelevantProjections opts     ] ++-  [ "--experimental-irrelevance"                 | optExperimentalIrrelevance opts   ] ++-  [ "--rewriting"                                | optRewriting opts                 ] ++-  [ "--cubical and --with-K"                     | optCubical opts-                                                 , not (collapseDefault $ optWithoutK opts) ] ++-  [ "--cumulativity"                             | optCumulativity opts              ] ++-  []---- | If any these options have changed, then the file will be---   rechecked. Boolean options are negated to mention non-default---   options, where possible.--restartOptions :: [(PragmaOptions -> RestartCodomain, String)]-restartOptions =-  [ (C . optTerminationDepth, "--termination-depth")-  , (B . not . optUseUnicode, "--no-unicode")-  , (B . optAllowUnsolved, "--allow-unsolved-metas")-  , (B . optAllowIncompleteMatch, "--allow-incomplete-matches")-  , (B . optDisablePositivity, "--no-positivity-check")-  , (B . optTerminationCheck,  "--no-termination-check")-  , (B . not . optUniverseCheck, "--type-in-type")-  , (B . optOmegaInOmega, "--omega-in-omega")-  , (B . collapseDefault . optSubtyping, "--subtyping")-  , (B . optCumulativity, "--cumulativity")-  , (B . not . collapseDefault . optSizedTypes, "--no-sized-types")-  , (B . not . collapseDefault . optGuardedness, "--no-guardedness")-  , (B . optInjectiveTypeConstructors, "--injective-type-constructors")-  , (B . optProp, "--prop")-  , (B . not . optUniversePolymorphism, "--no-universe-polymorphism")-  , (B . optIrrelevantProjections, "--irrelevant-projections")-  , (B . optExperimentalIrrelevance, "--experimental-irrelevance")-  , (B . collapseDefault . optWithoutK, "--without-K")-  , (B . optExactSplit, "--exact-split")-  , (B . not . optEta, "--no-eta-equality")-  , (B . optRewriting, "--rewriting")-  , (B . optCubical, "--cubical")-  , (B . optOverlappingInstances, "--overlapping-instances")-  , (B . optSafe, "--safe")-  , (B . optDoubleCheck, "--double-check")-  , (B . not . optSyntacticEquality, "--no-syntactic-equality")-  , (B . not . optCompareSorts, "--no-sort-comparison")-  , (B . not . optAutoInline, "--no-auto-inline")-  , (B . not . optFastReduce, "--no-fast-reduce")-  , (I . optInstanceSearchDepth, "--instance-search-depth")-  , (I . optInversionMaxDepth, "--inversion-max-depth")-  , (W . optWarningMode, "--warning")-  , (B . optConfluenceCheck, "--confluence-check")-  ]---- to make all restart options have the same type-data RestartCodomain = C CutOff | B Bool | I Int | W WarningMode-  deriving Eq---- | An infective option is an option that if used in one module, must---   be used in all modules that depend on this module.--infectiveOptions :: [(PragmaOptions -> Bool, String)]-infectiveOptions =-  [ (optCubical, "--cubical")-  , (optProp, "--prop")-  ]---- | A coinfective option is an option that if used in one module, must---   be used in all modules that this module depends on.--coinfectiveOptions :: [(PragmaOptions -> Bool, String)]-coinfectiveOptions =-  [ (optSafe, "--safe")-  , (collapseDefault . optWithoutK, "--without-K")-  , (not . optUniversePolymorphism, "--no-universe-polymorphism")-  , (not . collapseDefault . optSizedTypes, "--no-sized-types")-  , (not . collapseDefault . optGuardedness, "--no-guardedness")-  , (not . collapseDefault . optSubtyping, "--no-subtyping")-  , (not . optCumulativity, "--no-cumulativity")-  ]--inputFlag :: FilePath -> Flag CommandLineOptions-inputFlag f o =-    case optInputFile o of-        Nothing  -> return $ o { optInputFile = Just f }-        Just _   -> throwError "only one input file allowed"--versionFlag :: Flag CommandLineOptions-versionFlag o = return $ o { optShowVersion = True }--helpFlag :: Maybe String -> Flag CommandLineOptions-helpFlag Nothing    o = return $ o { optShowHelp = Just GeneralHelp }-helpFlag (Just str) o = case string2HelpTopic str of-  Just hpt -> return $ o { optShowHelp = Just (HelpFor hpt) }-  Nothing -> throwError $ "unknown help topic " ++ str ++ " (available: " ++-                           intercalate ", " (map fst allHelpTopics) ++ ")"--safeFlag :: Flag PragmaOptions-safeFlag o = do-  let guardedness = optGuardedness o-  let sizedTypes  = optSizedTypes o-  return $ o { optSafe        = True-             , optGuardedness = setDefault False guardedness-             , optSizedTypes  = setDefault False sizedTypes-             }--flatSplitFlag :: Flag PragmaOptions-flatSplitFlag o = return $ o { optFlatSplit = True }--noFlatSplitFlag :: Flag PragmaOptions-noFlatSplitFlag o = return $ o { optFlatSplit = False }--doubleCheckFlag :: Flag PragmaOptions-doubleCheckFlag o = return $ o { optDoubleCheck = True }--noSyntacticEqualityFlag :: Flag PragmaOptions-noSyntacticEqualityFlag o = return $ o { optSyntacticEquality = False }--noSortComparisonFlag :: Flag PragmaOptions-noSortComparisonFlag o = return $ o { optCompareSorts = False }--sharingFlag :: Bool -> Flag CommandLineOptions-sharingFlag _ _ = throwError $-  "Feature --sharing has been removed (in favor of the Agda abstract machine)."--cachingFlag :: Bool -> Flag PragmaOptions-cachingFlag b o = return $ o { optCaching = b }--propFlag :: Flag PragmaOptions-propFlag o = return $ o { optProp = True }--noPropFlag :: Flag PragmaOptions-noPropFlag o = return $ o { optProp = False }--experimentalIrrelevanceFlag :: Flag PragmaOptions-experimentalIrrelevanceFlag o = return $ o { optExperimentalIrrelevance = True }--irrelevantProjectionsFlag :: Flag PragmaOptions-irrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = True }--noIrrelevantProjectionsFlag :: Flag PragmaOptions-noIrrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = False }--ignoreInterfacesFlag :: Flag CommandLineOptions-ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }--ignoreAllInterfacesFlag :: Flag CommandLineOptions-ignoreAllInterfacesFlag o = return $ o { optIgnoreAllInterfaces = True }--localInterfacesFlag :: Flag CommandLineOptions-localInterfacesFlag o = return $ o { optLocalInterfaces = True }--allowUnsolvedFlag :: Flag PragmaOptions-allowUnsolvedFlag o = do-  let upd = over warningSet (Set.\\ unsolvedWarnings)-  return $ o { optAllowUnsolved = True-             , optWarningMode   = upd (optWarningMode o)-             }--allowIncompleteMatchFlag :: Flag PragmaOptions-allowIncompleteMatchFlag o = do-  let upd = over warningSet (Set.\\ incompleteMatchWarnings)-  return $ o { optAllowIncompleteMatch = True-             , optWarningMode          = upd (optWarningMode o)-             }--showImplicitFlag :: Flag PragmaOptions-showImplicitFlag o = return $ o { optShowImplicit = True }--showIrrelevantFlag :: Flag PragmaOptions-showIrrelevantFlag o = return $ o { optShowIrrelevant = True }--asciiOnlyFlag :: Flag PragmaOptions-asciiOnlyFlag o = do-  lift $ writeIORef unicodeOrAscii AsciiOnly-  return $ o { optUseUnicode = False }--ghciInteractionFlag :: Flag CommandLineOptions-ghciInteractionFlag o = return $ o { optGHCiInteraction = True }--jsonInteractionFlag :: Flag CommandLineOptions-jsonInteractionFlag o = return $ o { optJSONInteraction = True }--vimFlag :: Flag CommandLineOptions-vimFlag o = return $ o { optGenerateVimFile = True }--latexFlag :: Flag CommandLineOptions-latexFlag o = return $ o { optGenerateLaTeX = True }--onlyScopeCheckingFlag :: Flag CommandLineOptions-onlyScopeCheckingFlag o = return $ o { optOnlyScopeChecking = True }--countClustersFlag :: Flag PragmaOptions-countClustersFlag o =-#ifdef COUNT_CLUSTERS-  return $ o { optCountClusters = True }-#else-  throwError-    "Cluster counting has not been enabled in this build of Agda."-#endif--noAutoInlineFlag :: Flag PragmaOptions-noAutoInlineFlag o = return $ o { optAutoInline = False }--noPrintPatSynFlag :: Flag PragmaOptions-noPrintPatSynFlag o = return $ o { optPrintPatternSynonyms = False }--noFastReduceFlag :: Flag PragmaOptions-noFastReduceFlag o = return $ o { optFastReduce = False }--latexDirFlag :: FilePath -> Flag CommandLineOptions-latexDirFlag d o = return $ o { optLaTeXDir = d }--noPositivityFlag :: Flag PragmaOptions-noPositivityFlag o = do-  let upd = over warningSet (Set.delete NotStrictlyPositive_)-  return $ o { optDisablePositivity = True-             , optWarningMode   = upd (optWarningMode o)-             }--dontTerminationCheckFlag :: Flag PragmaOptions-dontTerminationCheckFlag o = do-  let upd = over warningSet (Set.delete TerminationIssue_)-  return $ o { optTerminationCheck = False-             , optWarningMode   = upd (optWarningMode o)-             }---- The option was removed. See Issue 1918.-dontCompletenessCheckFlag :: Flag PragmaOptions-dontCompletenessCheckFlag _ =-  throwError "The --no-coverage-check option has been removed."--dontUniverseCheckFlag :: Flag PragmaOptions-dontUniverseCheckFlag o = return $ o { optUniverseCheck = False }--omegaInOmegaFlag :: Flag PragmaOptions-omegaInOmegaFlag o = return $ o { optOmegaInOmega = True }--subtypingFlag :: Flag PragmaOptions-subtypingFlag o = return $ o { optSubtyping = Value True }--noSubtypingFlag :: Flag PragmaOptions-noSubtypingFlag o = return $ o { optSubtyping = Value False }--cumulativityFlag :: Flag PragmaOptions-cumulativityFlag o =-  return $ o { optCumulativity = True-             , optSubtyping    = setDefault True $ optSubtyping o-             }--noCumulativityFlag :: Flag PragmaOptions-noCumulativityFlag o = return $ o { optCumulativity = False }----UNUSED Liang-Ting Chen 2019-07-16---etaFlag :: Flag PragmaOptions---etaFlag o = return $ o { optEta = True }--noEtaFlag :: Flag PragmaOptions-noEtaFlag o = return $ o { optEta = False }--sizedTypes :: Flag PragmaOptions-sizedTypes o =-  return $ o { optSizedTypes = Value True-             --, optSubtyping  = setDefault True $ optSubtyping o-             }--noSizedTypes :: Flag PragmaOptions-noSizedTypes o = return $ o { optSizedTypes = Value False }--guardedness :: Flag PragmaOptions-guardedness o = return $ o { optGuardedness = Value True }--noGuardedness :: Flag PragmaOptions-noGuardedness o = return $ o { optGuardedness = Value False }--injectiveTypeConstructorFlag :: Flag PragmaOptions-injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True }--guardingTypeConstructorFlag :: Flag PragmaOptions-guardingTypeConstructorFlag _ = throwError $-  "Experimental feature --guardedness-preserving-type-constructors has been removed."--universePolymorphismFlag :: Flag PragmaOptions-universePolymorphismFlag o = return $ o { optUniversePolymorphism = True }--noUniversePolymorphismFlag :: Flag PragmaOptions-noUniversePolymorphismFlag  o = return $ o { optUniversePolymorphism = False }--noForcingFlag :: Flag PragmaOptions-noForcingFlag o = return $ o { optForcing = False }--noProjectionLikeFlag :: Flag PragmaOptions-noProjectionLikeFlag o = return $ o { optProjectionLike = False }--withKFlag :: Flag PragmaOptions-withKFlag o = return $ o { optWithoutK = Value False }--withoutKFlag :: Flag PragmaOptions-withoutKFlag o = return $ o { optWithoutK = Value True }--copatternsFlag :: Flag PragmaOptions-copatternsFlag o = return $ o { optCopatterns = True }--noCopatternsFlag :: Flag PragmaOptions-noCopatternsFlag o = return $ o { optCopatterns = False }--noPatternMatchingFlag :: Flag PragmaOptions-noPatternMatchingFlag o = return $ o { optPatternMatching = False }--exactSplitFlag :: Flag PragmaOptions-exactSplitFlag o = do-  let upd = over warningSet (Set.insert CoverageNoExactSplit_)-  return $ o { optExactSplit = True-             , optWarningMode   = upd (optWarningMode o)-             }--noExactSplitFlag :: Flag PragmaOptions-noExactSplitFlag o = do-  let upd = over warningSet (Set.delete CoverageNoExactSplit_)-  return $ o { optExactSplit = False-             , optWarningMode   = upd (optWarningMode o)-             }--rewritingFlag :: Flag PragmaOptions-rewritingFlag o = return $ o { optRewriting = True }--cubicalFlag :: Flag PragmaOptions-cubicalFlag o = do-  let withoutK = optWithoutK o-  return $ o { optCubical  = True-             , optWithoutK = setDefault True withoutK-             }--postfixProjectionsFlag :: Flag PragmaOptions-postfixProjectionsFlag o = return $ o { optPostfixProjections = True }--keepPatternVariablesFlag :: Flag PragmaOptions-keepPatternVariablesFlag o = return $ o { optKeepPatternVariables = True }--instanceDepthFlag :: String -> Flag PragmaOptions-instanceDepthFlag s o = do-  d <- integerArgument "--instance-search-depth" s-  return $ o { optInstanceSearchDepth = d }--overlappingInstancesFlag :: Flag PragmaOptions-overlappingInstancesFlag o = return $ o { optOverlappingInstances = True }--noOverlappingInstancesFlag :: Flag PragmaOptions-noOverlappingInstancesFlag o = return $ o { optOverlappingInstances = False }--inversionMaxDepthFlag :: String -> Flag PragmaOptions-inversionMaxDepthFlag s o = do-  d <- integerArgument "--inversion-max-depth" s-  return $ o { optInversionMaxDepth = d }--interactiveFlag :: Flag CommandLineOptions-interactiveFlag  o = do-  prag <- allowUnsolvedFlag (optPragmaOptions o)-  return $ o { optInteractive    = True-             , optPragmaOptions = prag-             }--compileFlagNoMain :: Flag PragmaOptions-compileFlagNoMain o = return $ o { optCompileNoMain = True }--compileDirFlag :: FilePath -> Flag CommandLineOptions-compileDirFlag f o = return $ o { optCompileDir = Just f }--htmlFlag :: Flag CommandLineOptions-htmlFlag o = return $ o { optGenerateHTML = True }--htmlHighlightFlag :: String -> Flag CommandLineOptions-htmlHighlightFlag "code" o = return $ o { optHTMLHighlight = HighlightCode }-htmlHighlightFlag "all"  o = return $ o { optHTMLHighlight = HighlightAll  }-htmlHighlightFlag "auto" o = return $ o { optHTMLHighlight = HighlightAuto  }-htmlHighlightFlag opt    o = throwError $ "Invalid option <" ++ opt-  ++ ">, expected <all>, <auto> or <code>"--dependencyGraphFlag :: FilePath -> Flag CommandLineOptions-dependencyGraphFlag f o = return $ o { optDependencyGraph = Just f }--htmlDirFlag :: FilePath -> Flag CommandLineOptions-htmlDirFlag d o = return $ o { optHTMLDir = d }--cssFlag :: FilePath -> Flag CommandLineOptions-cssFlag f o = return $ o { optCSSFile = Just f }--includeFlag :: FilePath -> Flag CommandLineOptions-includeFlag d o = return $ o { optIncludePaths = d : optIncludePaths o }--libraryFlag :: String -> Flag CommandLineOptions-libraryFlag s o = return $ o { optLibraries = optLibraries o ++ [s] }--overrideLibrariesFileFlag :: String -> Flag CommandLineOptions-overrideLibrariesFileFlag s o = do-  ifM (liftIO $ doesFileExist s)-    {-then-} (return $ o { optOverrideLibrariesFile = Just s-                         , optUseLibs = True-                         })-    {-else-} (throwError $ "Libraries file not found: " ++ s)--noDefaultLibsFlag :: Flag CommandLineOptions-noDefaultLibsFlag o = return $ o { optDefaultLibs = False }--noLibsFlag :: Flag CommandLineOptions-noLibsFlag o = return $ o { optUseLibs = False }--verboseFlag :: String -> Flag PragmaOptions-verboseFlag s o =-    do  (k,n) <- parseVerbose s-        return $ o { optVerbose = Trie.insert k n $ optVerbose o }-  where-    parseVerbose s = case wordsBy (`elem` (":." :: String)) s of-      []  -> usage-      ss  -> do-        n <- readM (last ss) `catchError` \_ -> usage-        return (init ss, n)-    usage = throwError "argument to verbose should be on the form x.y.z:N or N"--warningModeFlag :: String -> Flag PragmaOptions-warningModeFlag s o = case warningModeUpdate s of-  Just upd -> return $ o { optWarningMode = upd (optWarningMode o) }-  Nothing  -> throwError $ "unknown warning flag " ++ s ++ ". See --help=warning."--terminationDepthFlag :: String -> Flag PragmaOptions-terminationDepthFlag s o =-    do k <- readM s `catchError` \_ -> usage-       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 :: Flag PragmaOptions-confluenceCheckFlag o = return $ o { optConfluenceCheck = True }--noConfluenceCheckFlag :: Flag PragmaOptions-noConfluenceCheckFlag o = return $ o { optConfluenceCheck = False }--withCompilerFlag :: FilePath -> Flag CommandLineOptions-withCompilerFlag fp o = case optWithCompiler o of- Nothing -> pure o { optWithCompiler = Just fp }- Just{}  -> throwError "only one compiler path allowed"---integerArgument :: String -> String -> OptM Int-integerArgument flag s =-    readM s `catchError` \_ ->-        throwError $ "option '" ++ flag ++ "' requires an integer argument"--standardOptions :: [OptDescr (Flag CommandLineOptions)]-standardOptions =-    [ Option ['V']  ["version"] (NoArg versionFlag)       "show version number"-    , Option ['?']  ["help"]    (OptArg helpFlag "TOPIC")-                      ("show help for TOPIC (available: "-                       ++ intercalate ", " (map fst allHelpTopics)-                       ++ ")")-    , 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 []     ["compile-dir"] (ReqArg compileDirFlag "DIR")-                    ("directory for compiler output (default: the project root)")--    , Option []     ["vim"] (NoArg vimFlag)-                    "generate Vim highlighting files"-    , Option []     ["latex"] (NoArg latexFlag)-                    "generate LaTeX with highlighted source code"-    , Option []     ["latex-dir"] (ReqArg latexDirFlag "DIR")-                    ("directory in which LaTeX files are placed (default: " ++-                     defaultLaTeXDir ++ ")")-    , Option []     ["html"] (NoArg htmlFlag)-                    "generate HTML files with highlighted source code"-    , Option []     ["html-dir"] (ReqArg htmlDirFlag "DIR")-                    ("directory in which HTML files are placed (default: " ++-                     defaultHTMLDir ++ ")")-    , Option []     ["css"] (ReqArg cssFlag "URL")-                    "the CSS file used by the HTML files (can be relative)"-    , Option []     ["html-highlight"] (ReqArg htmlHighlightFlag "[code,all,auto]")-                    ("whether to highlight only the code parts (code) or " ++-                    "the file as a whole (all) or " ++-                    "decide by source file type (auto)")-    , Option []     ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")-                    "generate a Dot file with a module dependency graph"-    , Option []     ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)-                    "ignore interface files (re-type check everything)"-    , Option []     ["local-interfaces"] (NoArg localInterfacesFlag)-                    "put interface files next to the Agda files they correspond to"-    , 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 []     ["with-compiler"] (ReqArg withCompilerFlag "PATH")-                    "use the compiler available at PATH"-    ] ++ map (fmap lensPragmaOptions) pragmaOptions---- | Defined locally here since module ''Agda.Interaction.Options.Lenses''---   has cyclic dependency.-lensPragmaOptions :: Lens' PragmaOptions CommandLineOptions-lensPragmaOptions f st = f (optPragmaOptions st) <&> \ opts -> st { optPragmaOptions = opts }---- | 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 =-    [ Option []     ["sharing"] (NoArg $ sharingFlag True)-                    "DEPRECATED: does nothing"-    , Option []     ["no-sharing"] (NoArg $ sharingFlag False)-                    "DEPRECATED: does nothing"-    , Option []     ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden-                    "ignore all interface files (re-type check everything, including builtin files)"-    ] ++ map (fmap lensPragmaOptions) deadPragmaOptions--pragmaOptions :: [OptDescr (Flag PragmaOptions)]-pragmaOptions =-    [ Option []     ["show-implicit"] (NoArg showImplicitFlag)-                    "show implicit arguments when printing"-    , Option []     ["show-irrelevant"] (NoArg showIrrelevantFlag)-                    "show irrelevant arguments when printing"-    , Option []     ["no-unicode"] (NoArg asciiOnlyFlag)-                    "don't use unicode characters when printing terms"-    , Option ['v']  ["verbose"] (ReqArg verboseFlag "N")-                    "set verbosity level to N"-    , Option []     ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)-                    "succeed and create interface file regardless of unsolved meta variables"-    , Option []     ["allow-incomplete-matches"] (NoArg allowIncompleteMatchFlag)-                    "succeed and create interface file regardless of incomplete pattern matches"-    , Option []     ["no-positivity-check"] (NoArg noPositivityFlag)-                    "do not warn about not strictly positive data types"-    , Option []     ["no-termination-check"] (NoArg dontTerminationCheckFlag)-                    "do not warn about possibly nonterminating code"-    , Option []     ["termination-depth"] (ReqArg terminationDepthFlag "N")-                    "allow termination checker to count decrease/increase upto N (default N=1)"-    , Option []     ["type-in-type"] (NoArg dontUniverseCheckFlag)-                    "ignore universe levels (this makes Agda inconsistent)"-    , Option []     ["omega-in-omega"] (NoArg omegaInOmegaFlag)-                    "enable typing rule Setω : Setω (this makes Agda inconsistent)"-    , Option []     ["subtyping"] (NoArg subtypingFlag)-                    "enable subtyping rules in general (e.g. for irrelevance and erasure)"-    , Option []     ["no-subtyping"] (NoArg noSubtypingFlag)-                    "disable subtyping rules in general (e.g. for irrelevance and erasure) (default)"-    , Option []     ["cumulativity"] (NoArg cumulativityFlag)-                    "enable subtyping of universes (e.g. Set =< Set₁) (implies --subtyping)"-    , Option []     ["no-cumulativity"] (NoArg noCumulativityFlag)-                    "disable subtyping of universes (default)"-    , Option []     ["prop"] (NoArg propFlag)-                    "enable the use of the Prop universe"-    , Option []     ["no-prop"] (NoArg noPropFlag)-                    "disable the use of the Prop universe (default)"-    , Option []     ["sized-types"] (NoArg sizedTypes)-                    "enable sized types (default, inconsistent with --guardedness, implies --subtyping)"-    , Option []     ["no-sized-types"] (NoArg noSizedTypes)-                    "disable sized types"-    , Option []     ["flat-split"] (NoArg flatSplitFlag)-                    "allow split on (x :{flat} A) arguments (default)"-    , Option []     ["no-flat-split"] (NoArg noFlatSplitFlag)-                    "disable split on (x :{flat} A) arguments"-    , Option []     ["guardedness"] (NoArg guardedness)-                    "enable constructor-based guarded corecursion (default, inconsistent with --sized-types)"-    , Option []     ["no-guardedness"] (NoArg noGuardedness)-                    "disable constructor-based guarded corecursion"-    , Option []     ["injective-type-constructors"] (NoArg injectiveTypeConstructorFlag)-                    "enable injective type constructors (makes Agda anti-classical and possibly inconsistent)"-    , Option []     ["no-universe-polymorphism"] (NoArg noUniversePolymorphismFlag)-                    "disable universe polymorphism"-    , Option []     ["universe-polymorphism"] (NoArg universePolymorphismFlag)-                    "enable universe polymorphism (default)"-    , Option []     ["irrelevant-projections"] (NoArg irrelevantProjectionsFlag)-                    "enable projection of irrelevant record fields and similar irrelevant definitions (inconsistent)"-    , Option []     ["no-irrelevant-projections"] (NoArg noIrrelevantProjectionsFlag)-                    "disable projection of irrelevant record fields and similar irrelevant definitions (default)"-    , Option []     ["experimental-irrelevance"] (NoArg experimentalIrrelevanceFlag)-                    "enable potentially unsound irrelevance features (irrelevant levels, irrelevant data matching)"-    , Option []     ["with-K"] (NoArg withKFlag)-                    "enable the K rule in pattern matching (default)"-    , Option []     ["without-K"] (NoArg withoutKFlag)-                    "disable the K rule in pattern matching"-    , Option []     ["copatterns"] (NoArg copatternsFlag)-                    "enable definitions by copattern matching (default)"-    , Option []     ["no-copatterns"] (NoArg noCopatternsFlag)-                    "disable definitions by copattern matching"-    , Option []     ["no-pattern-matching"] (NoArg noPatternMatchingFlag)-                    "disable pattern matching completely"-    , Option []     ["exact-split"] (NoArg exactSplitFlag)-                    "require all clauses in a definition to hold as definitional equalities (unless marked CATCHALL)"-    , Option []     ["no-exact-split"] (NoArg noExactSplitFlag)-                    "do not require all clauses in a definition to hold as definitional equalities (default)"-    , Option []     ["no-eta-equality"] (NoArg noEtaFlag)-                    "default records to no-eta-equality"-    , Option []     ["no-forcing"] (NoArg noForcingFlag)-                    "disable the forcing analysis for data constructors (optimisation)"-    , Option []     ["no-projection-like"] (NoArg noProjectionLikeFlag)-                    "disable the analysis whether function signatures liken those of projections (optimisation)"-    , Option []     ["rewriting"] (NoArg rewritingFlag)-                    "enable declaration and use of REWRITE rules"-    , Option []     ["confluence-check"] (NoArg confluenceCheckFlag)-                    "enable confluence checking of REWRITE rules"-    , Option []     ["no-confluence-check"] (NoArg noConfluenceCheckFlag)-                    "disalbe confluence checking of REWRITE rules (default)"-    , Option []     ["cubical"] (NoArg cubicalFlag)-                    "enable cubical features (e.g. overloads lambdas for paths), implies --without-K"-    , Option []     ["postfix-projections"] (NoArg postfixProjectionsFlag)-                    "make postfix projection notation the default"-    , Option []     ["keep-pattern-variables"] (NoArg keepPatternVariablesFlag)-                    "don't replace variables with dot patterns during case splitting"-    , Option []     ["instance-search-depth"] (ReqArg instanceDepthFlag "N")-                    "set instance search depth to N (default: 500)"-    , Option []     ["overlapping-instances"] (NoArg overlappingInstancesFlag)-                    "consider recursive instance arguments during pruning of instance candidates"-    , Option []     ["no-overlapping-instances"] (NoArg noOverlappingInstancesFlag)-                    "don't consider recursive instance arguments during pruning of instance candidates (default)"-    , 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 and --no-guardedness "-    , Option []     ["double-check"] (NoArg doubleCheckFlag)-                    "enable double-checking of all terms using the internal typechecker"-    , Option []     ["no-syntactic-equality"] (NoArg noSyntacticEqualityFlag)-                    "disable the syntactic equality shortcut in the conversion checker"-    , Option []     ["no-sort-comparison"] (NoArg noSortComparisonFlag)-                    "disable the comparison of sorts when checking conversion of types"-    , Option ['W']  ["warning"] (ReqArg warningModeFlag "FLAG")-                    ("set warning flags. See --help=warning.")-    , Option []     ["no-main"] (NoArg compileFlagNoMain)-                    "do not treat the requested module as the main module of a program when compiling"-    , Option []     ["caching"] (NoArg $ cachingFlag True)-                    "enable caching of typechecking (default)"-    , Option []     ["no-caching"] (NoArg $ cachingFlag False)-                    "disable caching of typechecking"-    , Option []     ["count-clusters"] (NoArg countClustersFlag)-                    ("count extended grapheme clusters when " ++-                     "generating LaTeX (note that this flag " ++-#ifdef COUNT_CLUSTERS-                     "is not enabled in all builds of Agda)"-#else-                     "has not been enabled in this build of Agda)"-#endif-                    )-    , Option []     ["no-auto-inline"] (NoArg noAutoInlineFlag)-                    ("disable automatic compile-time inlining " ++-                     "(only definitions marked INLINE will be inlined)")-    , Option []     ["no-print-pattern-synonyms"] (NoArg noPrintPatSynFlag)-                    "expand pattern synonyms when printing terms"-    , Option []     ["no-fast-reduce"] (NoArg noFastReduceFlag)-                    "disable reduction using the Agda Abstract Machine"-    ]---- | Pragma options of previous versions of Agda.---   Should not be listed in the usage info, put parsed by GetOpt for good error messaging.-deadPragmaOptions :: [OptDescr (Flag PragmaOptions)]-deadPragmaOptions =-    [ Option []     ["guardedness-preserving-type-constructors"] (NoArg guardingTypeConstructorFlag)-                    "treat type constructors as inductive constructors when checking productivity"-    , Option []     ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)-                    "the option has been removed"-    ]---- | Used for printing usage info.---   Does not include the dead options.-standardOptions_ :: [OptDescr ()]-standardOptions_ = map (fmap $ const ()) standardOptions---- | Simple interface for System.Console.GetOpt---   Could be moved to Agda.Utils.Options (does not exist yet)-getOptSimple-  :: [String]               -- ^ command line argument words-  -> [OptDescr (Flag opts)] -- ^ options handlers-  -> (String -> Flag opts)  -- ^ handler of non-options (only one is allowed)-  -> Flag opts              -- ^ combined opts data structure transformer-getOptSimple argv opts fileArg = \ defaults ->-  case getOpt' (ReturnInOrder fileArg) opts argv of-    (o, _, []          , [] )  -> foldl (>>=) (return defaults) o-    (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg--      where-      ucap = "Unrecognized " ++ plural unrecognized "option" ++ ":"-      ecap = plural errs "Option error" ++ ":"-      umsg = if null unrecognized then "" else unlines $-       ucap : map suggest unrecognized-      emsg = if null errs then "" else unlines $-       ecap : errs-      plural [_] x = x-      plural _   x = x ++ "s"--      -- Suggest alternatives that are at most 3 typos away--      longopts :: [String]-      longopts = map ("--" ++) $ concat $ map (\ (Option _ long _ _) -> long) opts--      dist :: String -> String -> Int-      dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t--      close :: String -> String -> Maybe (Int, String)-      close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing--      closeopts :: String -> [(Int, String)]-      closeopts s = mapMaybe (close s) longopts--      alts :: String -> [[String]]-      alts s = map (map snd) $ groupOn fst $ closeopts s--      suggest :: String -> String-      suggest s = case alts s of-        []     -> s-        as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"--      sugs :: [String] -> String-      sugs [a] = a-      sugs as  = "any of " ++ intercalate " " as--{- No longer used in favour of parseBackendOptions in Agda.Compiler.Backend--- | Parse the standard options.-parseStandardOptions :: [String] -> OptM CommandLineOptions-parseStandardOptions argv = parseStandardOptions' argv defaultOptions--parseStandardOptions' :: [String] -> Flag CommandLineOptions-parseStandardOptions' argv opts = do-  opts <- getOptSimple (stripRTS argv) (deadStandardOptions ++ standardOptions) inputFlag opts-  checkOpts opts--}---- | Parse options from an options pragma.-parsePragmaOptions-  :: [String]-     -- ^ Pragma options.-  -> CommandLineOptions-     -- ^ Command-line options which should be updated.-  -> OptM PragmaOptions-parsePragmaOptions argv opts = do-  ps <- getOptSimple argv (deadPragmaOptions ++ pragmaOptions)-          (\s _ -> throwError $ "Bad option in pragma: " ++ s)-          (optPragmaOptions opts)-  _ <- checkOpts (opts { optPragmaOptions = ps })-  return 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)----------------------------------------------------------------------------- Some paths---- | Returns the absolute default lib dir. This directory is used to--- store the Primitive.agda file.-defaultLibDir :: IO FilePath-defaultLibDir = do-  libdir <- fmap filePath (absolute =<< getDataFileName "lib")-  ifM (doesDirectoryExist libdir)-      (return libdir)-      (error $ "The lib directory " ++ libdir ++ " does not exist")+module Agda.Interaction.Options+    ( module Opts.Base+    , module Opts.HasOptions+    ) where++import Agda.Interaction.Options.Base as Opts.Base+import Agda.Interaction.Options.HasOptions as Opts.HasOptions

+ src/full/Agda/Interaction/Options/Base.hs view

@@ -0,0 +1,1146 @@+{-# LANGUAGE CPP       #-}+{-# LANGUAGE DataKinds #-}++module Agda.Interaction.Options.Base+    ( CommandLineOptions(..)+    , PragmaOptions(..)+    , OptionsPragma+    , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)+    , Verbosity, VerboseKey, VerboseLevel+    , WarningMode(..)+    , ConfluenceCheck(..)+    , UnicodeOrAscii(..)+    , checkOpts+    , parsePragmaOptions+    , parsePluginOptions+    , stripRTS+    , defaultOptions+    , defaultInteractionOptions+    , defaultVerbosity+    , defaultCutOff+    , defaultPragmaOptions+    , standardOptions_+    , unsafePragmaOptions+    , restartOptions+    , infectiveOptions+    , coinfectiveOptions+    , safeFlag+    , mapFlag+    , usage+    -- Reused by PandocAgda+    , inputFlag+    , standardOptions, deadStandardOptions+    , getOptSimple+    ) where++import Control.DeepSeq+import Control.Monad ( when, void )+import Control.Monad.Except ( Except, MonadError(throwError), runExcept )++import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)+import Data.Maybe+import Data.Map                 ( Map )+import qualified Data.Map as Map+import Data.List                ( intercalate )+import qualified Data.Set as Set++import GHC.Generics (Generic)++import System.Console.GetOpt    ( getOpt', usageInfo, ArgOrder(ReturnInOrder)+                                , OptDescr(..), ArgDescr(..)+                                )+import Text.EditDistance+import Text.Read                ( readMaybe )++import Agda.Termination.CutOff  ( CutOff(..), defaultCutOff )++import Agda.Interaction.Library ( ExeName, LibName )+import Agda.Interaction.Options.Help+  ( Help(HelpFor, GeneralHelp)+  , string2HelpTopic+  , allHelpTopics+  , helpTopicUsage+  )+import Agda.Interaction.Options.Warnings+import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) )++import Agda.Utils.FileName      ( AbsolutePath )+import Agda.Utils.Functor       ( (<&>) )+import Agda.Utils.Lens          ( Lens', over )+import Agda.Utils.List          ( groupOn, initLast1, wordsBy )+import Agda.Utils.Pretty        ( singPlural )+import Agda.Utils.Trie          ( Trie )+import qualified Agda.Utils.Trie as Trie+import Agda.Utils.WithDefault++import Agda.Version++-- OptDescr is a Functor --------------------------------------------------++type VerboseKey   = String+type VerboseLevel = Int+type Verbosity    = Trie VerboseKey VerboseLevel++-- Don't forget to update+--   doc/user-manual/tools/command-line-options.rst+-- if you make changes to the command-line options!++data CommandLineOptions = Options+  { optProgramName           :: String+  , optInputFile             :: Maybe FilePath+  , optIncludePaths          :: [FilePath]+  , optAbsoluteIncludePaths  :: [AbsolutePath]+  , optLibraries             :: [LibName]+  , optOverrideLibrariesFile :: Maybe FilePath+  -- ^ Use this (if Just) instead of .agda/libraries+  , optDefaultLibs           :: Bool+  -- ^ Use ~/.agda/defaults+  , optUseLibs               :: Bool+  -- ^ look for .agda-lib files+  , optTrustedExecutables             :: Map ExeName FilePath+  -- ^ Map names of trusted executables to absolute paths+  , optPrintAgdaDir          :: Bool+  , optPrintVersion          :: Bool+  , optPrintHelp             :: Maybe Help+  , optInteractive           :: Bool+      -- ^ Agda REPL (-I).+  , optGHCiInteraction       :: Bool+  , optJSONInteraction       :: Bool+  , optOptimSmashing         :: Bool+  , optCompileDir            :: Maybe FilePath+  -- ^ In the absence of a path the project root is used.+  , optGenerateVimFile       :: Bool+  , optIgnoreInterfaces      :: Bool+  , optIgnoreAllInterfaces   :: Bool+  , optLocalInterfaces       :: Bool+  , optPragmaOptions         :: PragmaOptions+  , optOnlyScopeChecking     :: Bool+    -- ^ Should the top-level module only be scope-checked, and not+    --   type-checked?+  }+  deriving (Show, Generic)++instance NFData CommandLineOptions++-- | Options which can be set in a pragma.++data PragmaOptions = PragmaOptions+  { optShowImplicit              :: Bool+  , optShowIrrelevant            :: Bool+  , optUseUnicode                :: UnicodeOrAscii+  , optVerbose                   :: Verbosity+  , optProp                      :: Bool+  , optTwoLevel                  :: WithDefault 'False+  , optAllowUnsolved             :: Bool+  , optAllowIncompleteMatch      :: Bool+  , optDisablePositivity         :: Bool+  , optTerminationCheck          :: Bool+  , optTerminationDepth          :: CutOff+    -- ^ Cut off structural order comparison at some depth in termination checker?+  , optCompletenessCheck         :: Bool+  , optUniverseCheck             :: Bool+  , optOmegaInOmega              :: Bool+  , optSubtyping                 :: WithDefault 'False+  , optCumulativity              :: Bool+  , optSizedTypes                :: WithDefault 'False+  , optGuardedness               :: WithDefault 'False+  , optInjectiveTypeConstructors :: Bool+  , optUniversePolymorphism      :: Bool+  , optIrrelevantProjections     :: Bool+  , optExperimentalIrrelevance   :: Bool  -- ^ irrelevant levels, irrelevant data matching+  , optWithoutK                  :: WithDefault 'False+  , optCopatterns                :: Bool  -- ^ Allow definitions by copattern matching?+  , optPatternMatching           :: Bool  -- ^ Is pattern matching allowed in the current file?+  , optExactSplit                :: Bool+  , optEta                       :: Bool+  , optForcing                   :: Bool  -- ^ Perform the forcing analysis on data constructors?+  , optProjectionLike            :: Bool  -- ^ Perform the projection-likeness analysis on functions?+  , optRewriting                 :: Bool  -- ^ Can rewrite rules be added and used?+  , optCubical                   :: Bool+  , optGuarded                   :: Bool+  , optFirstOrder                :: Bool  -- ^ Should we speculatively unify function applications as if they were injective?+  , optPostfixProjections        :: Bool+      -- ^ Should system generated projections 'ProjSystem' be printed+      --   postfix (True) or prefix (False).+  , optKeepPatternVariables      :: Bool+      -- ^ Should case splitting replace variables with dot patterns+      --   (False) or keep them as variables (True).+  , optInstanceSearchDepth       :: Int+  , optOverlappingInstances      :: Bool+  , optQualifiedInstances        :: Bool  -- ^ Should instance search consider instances with qualified names?+  , optInversionMaxDepth         :: Int+  , optSafe                      :: Bool+  , optDoubleCheck               :: Bool+  , optSyntacticEquality         :: Bool  -- ^ Should conversion checker use syntactic equality shortcut?+  , optWarningMode               :: WarningMode+  , optCompileNoMain             :: Bool+  , optCaching                   :: Bool+  , optCountClusters             :: Bool+    -- ^ Count extended grapheme clusters rather than code points when+    -- generating LaTeX.+  , optAutoInline                :: Bool+    -- ^ Automatic compile-time inlining for simple definitions (unless marked+    --   NOINLINE).+  , optPrintPatternSynonyms      :: Bool+  , optFastReduce                :: Bool+    -- ^ Use the Agda abstract machine (fastReduce)?+  , optCallByName                :: Bool+    -- ^ Use call-by-name instead of call-by-need+  , optConfluenceCheck           :: Maybe ConfluenceCheck+    -- ^ Check confluence of rewrite rules?+  , optFlatSplit                 :: Bool+     -- ^ Can we split on a (@flat x : A) argument?+  , optImportSorts               :: Bool+     -- ^ Should every top-level module start with an implicit statement+     --   @open import Agda.Primitive using (Set; Prop)@?+  , optAllowExec                 :: Bool+  , optShowIdentitySubstitutions :: Bool+    -- ^ Show identity substitutions when pretty-printing terms+    --   (i.e. always show all arguments of a metavariable)+  }+  deriving (Show, Eq, Generic)++instance NFData PragmaOptions++data ConfluenceCheck+  = LocalConfluenceCheck+  | GlobalConfluenceCheck+  deriving (Show, Eq, Generic)++instance NFData ConfluenceCheck++-- | The options from an @OPTIONS@ pragma.+--+-- In the future it might be nice to switch to a more structured+-- representation. Note that, currently, there is not a one-to-one+-- correspondence between list elements and options.+type OptionsPragma = [String]++-- | 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++defaultVerbosity :: Verbosity+defaultVerbosity = Trie.singleton [] 1++defaultInteractionOptions :: PragmaOptions+defaultInteractionOptions = defaultPragmaOptions++defaultOptions :: CommandLineOptions+defaultOptions = Options+  { optProgramName      = "agda"+  , optInputFile             = Nothing+  , optIncludePaths          = []+  , optAbsoluteIncludePaths  = []+  , optLibraries             = []+  , optOverrideLibrariesFile = Nothing+  , optDefaultLibs           = True+  , optUseLibs               = True+  , optTrustedExecutables    = Map.empty+  , optPrintAgdaDir          = False+  , optPrintVersion          = False+  , optPrintHelp             = Nothing+  , optInteractive           = False+  , optGHCiInteraction       = False+  , optJSONInteraction       = False+  , optOptimSmashing         = True+  , optCompileDir            = Nothing+  , optGenerateVimFile       = False+  , optIgnoreInterfaces      = False+  , optIgnoreAllInterfaces   = False+  , optLocalInterfaces       = False+  , optPragmaOptions         = defaultPragmaOptions+  , optOnlyScopeChecking     = False+  }++defaultPragmaOptions :: PragmaOptions+defaultPragmaOptions = PragmaOptions+  { optShowImplicit              = False+  , optShowIrrelevant            = False+  , optUseUnicode                = UnicodeOk+  , optVerbose                   = defaultVerbosity+  , optProp                      = False+  , optTwoLevel                  = Default+  , optExperimentalIrrelevance   = False+  , optIrrelevantProjections     = False -- off by default in > 2.5.4, see issue #2170+  , optAllowUnsolved             = False+  , optAllowIncompleteMatch      = False+  , optDisablePositivity         = False+  , optTerminationCheck          = True+  , optTerminationDepth          = defaultCutOff+  , optCompletenessCheck         = True+  , optUniverseCheck             = True+  , optOmegaInOmega              = False+  , optSubtyping                 = Default+  , optCumulativity              = False+  , optSizedTypes                = Default+  , optGuardedness               = Default+  , optInjectiveTypeConstructors = False+  , optUniversePolymorphism      = True+  , optWithoutK                  = Default+  , optCopatterns                = True+  , optPatternMatching           = True+  , optExactSplit                = False+  , optEta                       = True+  , optForcing                   = True+  , optProjectionLike            = True+  , optRewriting                 = False+  , optCubical                   = False+  , optGuarded                   = False+  , optFirstOrder                = False+  , optPostfixProjections        = False+  , optKeepPatternVariables      = False+  , optInstanceSearchDepth       = 500+  , optOverlappingInstances      = False+  , optQualifiedInstances        = True+  , optInversionMaxDepth         = 50+  , optSafe                      = False+  , optDoubleCheck               = False+  , optSyntacticEquality         = True+  , optWarningMode               = defaultWarningMode+  , optCompileNoMain             = False+  , optCaching                   = True+  , optCountClusters             = False+  , optAutoInline                = False+  , optPrintPatternSynonyms      = True+  , optFastReduce                = True+  , optCallByName                = False+  , optConfluenceCheck           = Nothing+  , optFlatSplit                 = True+  , optImportSorts               = True+  , optAllowExec                 = False+  , optShowIdentitySubstitutions = False+  }++type OptM = Except String++runOptM :: Monad m => OptM opts -> m (Either String opts)+runOptM = pure . runExcept++{- | @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++-- | Checks that the given options are consistent.++checkOpts :: Flag 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."+  return opts++-- | Check for unsafe pragmas. Gives a list of used unsafe flags.++unsafePragmaOptions :: CommandLineOptions -> PragmaOptions -> [String]+unsafePragmaOptions clo opts =+  [ "--allow-unsolved-metas"                     | optAllowUnsolved opts             ] +++  [ "--allow-incomplete-matches"                 | optAllowIncompleteMatch opts      ] +++  [ "--no-positivity-check"                      | optDisablePositivity opts         ] +++  [ "--no-termination-check"                     | not (optTerminationCheck opts)    ] +++  [ "--type-in-type"                             | not (optUniverseCheck opts)       ] +++  [ "--omega-in-omega"                           | optOmegaInOmega opts              ] +++  [ "--sized-types"                              | collapseDefault (optSizedTypes opts) ] +++  [ "--injective-type-constructors"              | optInjectiveTypeConstructors opts ] +++  [ "--irrelevant-projections"                   | optIrrelevantProjections opts     ] +++  [ "--experimental-irrelevance"                 | optExperimentalIrrelevance opts   ] +++  [ "--rewriting"                                | optRewriting opts                 ] +++  [ "--cubical and --with-K"                     | optCubical opts+                                                 , not (collapseDefault $ optWithoutK opts) ] +++  [ "--cumulativity"                             | optCumulativity opts              ] +++  [ "--allow-exec"                               | optAllowExec opts                 ] +++  []++-- | If any these options have changed, then the file will be+--   rechecked. Boolean options are negated to mention non-default+--   options, where possible.++restartOptions :: [(PragmaOptions -> RestartCodomain, String)]+restartOptions =+  [ (C . optTerminationDepth, "--termination-depth")+  , (B . (/= UnicodeOk) . optUseUnicode, "--no-unicode")+  , (B . optAllowUnsolved, "--allow-unsolved-metas")+  , (B . optAllowIncompleteMatch, "--allow-incomplete-matches")+  , (B . optDisablePositivity, "--no-positivity-check")+  , (B . optTerminationCheck,  "--no-termination-check")+  , (B . not . optUniverseCheck, "--type-in-type")+  , (B . optOmegaInOmega, "--omega-in-omega")+  , (B . collapseDefault . optSubtyping, "--subtyping")+  , (B . optCumulativity, "--cumulativity")+  , (B . collapseDefault . optSizedTypes, "--no-sized-types")+  , (B . collapseDefault . optGuardedness, "--no-guardedness")+  , (B . optInjectiveTypeConstructors, "--injective-type-constructors")+  , (B . optProp, "--prop")+  , (B . collapseDefault . optTwoLevel, "--two-level")+  , (B . not . optUniversePolymorphism, "--no-universe-polymorphism")+  , (B . optIrrelevantProjections, "--irrelevant-projections")+  , (B . optExperimentalIrrelevance, "--experimental-irrelevance")+  , (B . collapseDefault . optWithoutK, "--without-K")+  , (B . optExactSplit, "--exact-split")+  , (B . not . optEta, "--no-eta-equality")+  , (B . optRewriting, "--rewriting")+  , (B . optCubical, "--cubical")+  , (B . optGuarded, "--guarded")+  , (B . optOverlappingInstances, "--overlapping-instances")+  , (B . optQualifiedInstances, "--qualified-instances")+  , (B . not . optQualifiedInstances, "--no-qualified-instances")+  , (B . optSafe, "--safe")+  , (B . optDoubleCheck, "--double-check")+  , (B . not . optSyntacticEquality, "--no-syntactic-equality")+  , (B . not . optAutoInline, "--no-auto-inline")+  , (B . not . optFastReduce, "--no-fast-reduce")+  , (B . optCallByName, "--call-by-name")+  , (I . optInstanceSearchDepth, "--instance-search-depth")+  , (I . optInversionMaxDepth, "--inversion-max-depth")+  , (W . optWarningMode, "--warning")+  , (B . (== Just LocalConfluenceCheck) . optConfluenceCheck, "--local-confluence-check")+  , (B . (== Just GlobalConfluenceCheck) . optConfluenceCheck, "--confluence-check")+  , (B . not . optImportSorts, "--no-import-sorts")+  , (B . optAllowExec, "--allow-exec")+  ]++-- to make all restart options have the same type+data RestartCodomain = C CutOff | B Bool | I Int | W WarningMode+  deriving Eq++-- | An infective option is an option that if used in one module, must+--   be used in all modules that depend on this module.++infectiveOptions :: [(PragmaOptions -> Bool, String)]+infectiveOptions =+  [ (optCubical, "--cubical")+  , (optGuarded, "--guarded")+  , (optProp, "--prop")+  , (collapseDefault . optTwoLevel, "--two-level")+  , (optRewriting, "--rewriting")+  , (collapseDefault . optSizedTypes, "--sized-types")+  , (collapseDefault . optGuardedness, "--guardedness")+  ]++-- | A coinfective option is an option that if used in one module, must+--   be used in all modules that this module depends on.++coinfectiveOptions :: [(PragmaOptions -> Bool, String)]+coinfectiveOptions =+  [ (optSafe, "--safe")+  , (collapseDefault . optWithoutK, "--without-K")+  , (not . optUniversePolymorphism, "--no-universe-polymorphism")+  , (not . collapseDefault . optSubtyping, "--no-subtyping")+  , (not . optCumulativity, "--no-cumulativity")+  ]++inputFlag :: FilePath -> Flag CommandLineOptions+inputFlag f o =+    case optInputFile o of+        Nothing  -> return $ o { optInputFile = Just f }+        Just _   -> throwError "only one input file allowed"++printAgdaDirFlag :: Flag CommandLineOptions+printAgdaDirFlag o = return $ o { optPrintAgdaDir = True }++versionFlag :: Flag CommandLineOptions+versionFlag o = return $ o { optPrintVersion = True }++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 $ "unknown help topic " ++ str ++ " (available: " +++                           intercalate ", " (map fst allHelpTopics) ++ ")"++safeFlag :: Flag PragmaOptions+safeFlag o = do+  let sizedTypes  = optSizedTypes o+  return $ o { optSafe        = True+             , optSizedTypes  = setDefault False sizedTypes+             }++flatSplitFlag :: Flag PragmaOptions+flatSplitFlag o = return $ o { optFlatSplit = True }++noFlatSplitFlag :: Flag PragmaOptions+noFlatSplitFlag o = return $ o { optFlatSplit = False }++doubleCheckFlag :: Bool -> Flag PragmaOptions+doubleCheckFlag b o = return $ o { optDoubleCheck = b }++noSyntacticEqualityFlag :: Flag PragmaOptions+noSyntacticEqualityFlag o = return $ o { optSyntacticEquality = False }++noSortComparisonFlag :: Flag PragmaOptions+noSortComparisonFlag o = return o++sharingFlag :: Bool -> Flag CommandLineOptions+sharingFlag _ _ = throwError $+  "Feature --sharing has been removed (in favor of the Agda abstract machine)."++cachingFlag :: Bool -> Flag PragmaOptions+cachingFlag b o = return $ o { optCaching = b }++propFlag :: Flag PragmaOptions+propFlag o = return $ o { optProp = True }++noPropFlag :: Flag PragmaOptions+noPropFlag o = return $ o { optProp = False }++twoLevelFlag :: Flag PragmaOptions+twoLevelFlag o = return $ o { optTwoLevel = Value True }++experimentalIrrelevanceFlag :: Flag PragmaOptions+experimentalIrrelevanceFlag o = return $ o { optExperimentalIrrelevance = True }++irrelevantProjectionsFlag :: Flag PragmaOptions+irrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = True }++noIrrelevantProjectionsFlag :: Flag PragmaOptions+noIrrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = False }++ignoreInterfacesFlag :: Flag CommandLineOptions+ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }++ignoreAllInterfacesFlag :: Flag CommandLineOptions+ignoreAllInterfacesFlag o = return $ o { optIgnoreAllInterfaces = True }++localInterfacesFlag :: Flag CommandLineOptions+localInterfacesFlag o = return $ o { optLocalInterfaces = True }++allowUnsolvedFlag :: Flag PragmaOptions+allowUnsolvedFlag o = do+  let upd = over warningSet (Set.\\ unsolvedWarnings)+  return $ o { optAllowUnsolved = True+             , optWarningMode   = upd (optWarningMode o)+             }++allowIncompleteMatchFlag :: Flag PragmaOptions+allowIncompleteMatchFlag o = do+  let upd = over warningSet (Set.\\ incompleteMatchWarnings)+  return $ o { optAllowIncompleteMatch = True+             , optWarningMode          = upd (optWarningMode o)+             }++showImplicitFlag :: Flag PragmaOptions+showImplicitFlag o = return $ o { optShowImplicit = True }++showIrrelevantFlag :: Flag PragmaOptions+showIrrelevantFlag o = return $ o { optShowIrrelevant = True }++showIdentitySubstitutionsFlag :: Flag PragmaOptions+showIdentitySubstitutionsFlag o = return $ o { optShowIdentitySubstitutions = True }++asciiOnlyFlag :: Flag PragmaOptions+asciiOnlyFlag o = return $ UNSAFE.unsafePerformIO $ do+  unsafeSetUnicodeOrAscii AsciiOnly+  return $ o { optUseUnicode = AsciiOnly }++ghciInteractionFlag :: Flag CommandLineOptions+ghciInteractionFlag o = return $ o { optGHCiInteraction = True }++jsonInteractionFlag :: Flag CommandLineOptions+jsonInteractionFlag o = return $ o { optJSONInteraction = True }++vimFlag :: Flag CommandLineOptions+vimFlag o = return $ o { optGenerateVimFile = True }++onlyScopeCheckingFlag :: Flag CommandLineOptions+onlyScopeCheckingFlag o = return $ o { optOnlyScopeChecking = True }++countClustersFlag :: Flag PragmaOptions+countClustersFlag o =+#ifdef COUNT_CLUSTERS+  return $ o { optCountClusters = True }+#else+  throwError+    "Cluster counting has not been enabled in this build of Agda."+#endif++noAutoInlineFlag :: Flag PragmaOptions+noAutoInlineFlag o = return $ o { optAutoInline = False }++autoInlineFlag :: Flag PragmaOptions+autoInlineFlag o = return $ o { optAutoInline = True }++noPrintPatSynFlag :: Flag PragmaOptions+noPrintPatSynFlag o = return $ o { optPrintPatternSynonyms = False }++noFastReduceFlag :: Flag PragmaOptions+noFastReduceFlag o = return $ o { optFastReduce = False }++callByNameFlag :: Flag PragmaOptions+callByNameFlag o = return $ o { optCallByName = True }++noPositivityFlag :: Flag PragmaOptions+noPositivityFlag o = do+  let upd = over warningSet (Set.delete NotStrictlyPositive_)+  return $ o { optDisablePositivity = True+             , optWarningMode   = upd (optWarningMode o)+             }++dontTerminationCheckFlag :: Flag PragmaOptions+dontTerminationCheckFlag o = do+  let upd = over warningSet (Set.delete TerminationIssue_)+  return $ o { optTerminationCheck = False+             , optWarningMode   = upd (optWarningMode o)+             }++-- The option was removed. See Issue 1918.+dontCompletenessCheckFlag :: Flag PragmaOptions+dontCompletenessCheckFlag _ =+  throwError "The --no-coverage-check option has been removed."++dontUniverseCheckFlag :: Flag PragmaOptions+dontUniverseCheckFlag o = return $ o { optUniverseCheck = False }++omegaInOmegaFlag :: Flag PragmaOptions+omegaInOmegaFlag o = return $ o { optOmegaInOmega = True }++subtypingFlag :: Flag PragmaOptions+subtypingFlag o = return $ o { optSubtyping = Value True }++noSubtypingFlag :: Flag PragmaOptions+noSubtypingFlag o = return $ o { optSubtyping = Value False }++cumulativityFlag :: Flag PragmaOptions+cumulativityFlag o =+  return $ o { optCumulativity = True+             , optSubtyping    = setDefault True $ optSubtyping o+             }++noCumulativityFlag :: Flag PragmaOptions+noCumulativityFlag o = return $ o { optCumulativity = False }++--UNUSED Liang-Ting Chen 2019-07-16+--etaFlag :: Flag PragmaOptions+--etaFlag o = return $ o { optEta = True }++noEtaFlag :: Flag PragmaOptions+noEtaFlag o = return $ o { optEta = False }++sizedTypes :: Flag PragmaOptions+sizedTypes o =+  return $ o { optSizedTypes = Value True+             --, optSubtyping  = setDefault True $ optSubtyping o+             }++noSizedTypes :: Flag PragmaOptions+noSizedTypes o = return $ o { optSizedTypes = Value False }++guardedness :: Flag PragmaOptions+guardedness o = return $ o { optGuardedness = Value True }++noGuardedness :: Flag PragmaOptions+noGuardedness o = return $ o { optGuardedness = Value False }++injectiveTypeConstructorFlag :: Flag PragmaOptions+injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True }++guardingTypeConstructorFlag :: Flag PragmaOptions+guardingTypeConstructorFlag _ = throwError $+  "Experimental feature --guardedness-preserving-type-constructors has been removed."++universePolymorphismFlag :: Flag PragmaOptions+universePolymorphismFlag o = return $ o { optUniversePolymorphism = True }++noUniversePolymorphismFlag :: Flag PragmaOptions+noUniversePolymorphismFlag  o = return $ o { optUniversePolymorphism = False }++noForcingFlag :: Flag PragmaOptions+noForcingFlag o = return $ o { optForcing = False }++noProjectionLikeFlag :: Flag PragmaOptions+noProjectionLikeFlag o = return $ o { optProjectionLike = False }++withKFlag :: Flag PragmaOptions+withKFlag o = return $ o { optWithoutK = Value False }++withoutKFlag :: Flag PragmaOptions+withoutKFlag o = return $ o { optWithoutK = Value True }++copatternsFlag :: Flag PragmaOptions+copatternsFlag o = return $ o { optCopatterns = True }++noCopatternsFlag :: Flag PragmaOptions+noCopatternsFlag o = return $ o { optCopatterns = False }++noPatternMatchingFlag :: Flag PragmaOptions+noPatternMatchingFlag o = return $ o { optPatternMatching = False }++exactSplitFlag :: Flag PragmaOptions+exactSplitFlag o = do+  let upd = over warningSet (Set.insert CoverageNoExactSplit_)+  return $ o { optExactSplit = True+             , optWarningMode   = upd (optWarningMode o)+             }++noExactSplitFlag :: Flag PragmaOptions+noExactSplitFlag o = do+  let upd = over warningSet (Set.delete CoverageNoExactSplit_)+  return $ o { optExactSplit = False+             , optWarningMode   = upd (optWarningMode o)+             }++rewritingFlag :: Flag PragmaOptions+rewritingFlag o = return $ o { optRewriting = True }++firstOrderFlag :: Flag PragmaOptions+firstOrderFlag o = return $ o { optFirstOrder = True }++cubicalFlag :: Flag PragmaOptions+cubicalFlag o = do+  let withoutK = optWithoutK o+  return $ o { optCubical  = True+             , optWithoutK = setDefault True withoutK+             , optTwoLevel = setDefault True $ optTwoLevel o+             }++guardedFlag :: Flag PragmaOptions+guardedFlag o = do+  return $ o { optGuarded  = True }++postfixProjectionsFlag :: Flag PragmaOptions+postfixProjectionsFlag o = return $ o { optPostfixProjections = True }++keepPatternVariablesFlag :: Flag PragmaOptions+keepPatternVariablesFlag o = return $ o { optKeepPatternVariables = True }++instanceDepthFlag :: String -> Flag PragmaOptions+instanceDepthFlag s o = do+  d <- integerArgument "--instance-search-depth" s+  return $ o { optInstanceSearchDepth = d }++overlappingInstancesFlag :: Flag PragmaOptions+overlappingInstancesFlag o = return $ o { optOverlappingInstances = True }++noOverlappingInstancesFlag :: Flag PragmaOptions+noOverlappingInstancesFlag o = return $ o { optOverlappingInstances = False }++qualifiedInstancesFlag :: Flag PragmaOptions+qualifiedInstancesFlag o = return $ o { optQualifiedInstances = True }++noQualifiedInstancesFlag :: Flag PragmaOptions+noQualifiedInstancesFlag o = return $ o { optQualifiedInstances = False }++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 }++compileFlagNoMain :: Flag PragmaOptions+compileFlagNoMain o = return $ o { optCompileNoMain = 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 ++ [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 = Trie.insert k n $ optVerbose o }+  where+    parseVerbose :: String -> OptM ([VerboseKey], VerboseLevel)+    parseVerbose s = case wordsBy (`elem` (":." :: String)) s of+      []  -> usage+      s0:ss0 -> do+        let (ss, s) = initLast1 s0 ss0+        n <- maybe usage return $ readMaybe s+        return (ss, n)+    usage = throwError "argument to verbose should be on the form x.y.z:N or N"++warningModeFlag :: String -> Flag PragmaOptions+warningModeFlag s o = case warningModeUpdate s of+  Right upd -> return $ o { optWarningMode = upd (optWarningMode o) }+  Left err  -> throwError $ prettyWarningModeError err ++ " See --help=warning."++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 }++noImportSorts :: Flag PragmaOptions+noImportSorts o = return $ o { optImportSorts = False }++allowExec :: Flag PragmaOptions+allowExec o = return $ o { optAllowExec = True }++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 number and exit")++    , Option ['?']  ["help"]    (OptArg helpFlag "TOPIC") $ concat+                    [ "print help and exit; available "+                    , singPlural allHelpTopics "TOPIC" "TOPICs"+                    , ": "+                    , intercalate ", " $ map fst allHelpTopics+                    ]++    , Option []     ["print-agda-dir"] (NoArg printAgdaDirFlag)+                    ("print $AGDA_DIR and exit")++    , 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 []     ["compile-dir"] (ReqArg compileDirFlag "DIR")+                    ("directory for compiler output (default: the project root)")++    , Option []     ["vim"] (NoArg vimFlag)+                    "generate Vim highlighting files"+    , Option []     ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)+                    "ignore interface files (re-type check everything)"+    , Option []     ["local-interfaces"] (NoArg localInterfacesFlag)+                    "put interface files next to the Agda files they correspond to"+    , 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"+    ] ++ map (fmap lensPragmaOptions) pragmaOptions++-- | Defined locally here since module ''Agda.Interaction.Options.Lenses''+--   has cyclic dependency.+lensPragmaOptions :: Lens' PragmaOptions CommandLineOptions+lensPragmaOptions f st = f (optPragmaOptions st) <&> \ opts -> st { optPragmaOptions = opts }++-- | 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 =+    [ Option []     ["sharing"] (NoArg $ sharingFlag True)+                    "DEPRECATED: does nothing"+    , Option []     ["no-sharing"] (NoArg $ sharingFlag False)+                    "DEPRECATED: does nothing"+    , Option []     ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden+                    "ignore all interface files (re-type check everything, including builtin files)"+    ] ++ map (fmap lensPragmaOptions) deadPragmaOptions++pragmaOptions :: [OptDescr (Flag PragmaOptions)]+pragmaOptions =+    [ Option []     ["show-implicit"] (NoArg showImplicitFlag)+                    "show implicit arguments when printing"+    , Option []     ["show-irrelevant"] (NoArg showIrrelevantFlag)+                    "show irrelevant arguments when printing"+    , Option []     ["show-identity-substitutions"] (NoArg showIdentitySubstitutionsFlag)+                    "show all arguments of metavariables when printing terms"+    , Option []     ["no-unicode"] (NoArg asciiOnlyFlag)+                    "don't use unicode characters when printing terms"+    , Option ['v']  ["verbose"] (ReqArg verboseFlag "N")+                    "set verbosity level to N"+    , Option []     ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)+                    "succeed and create interface file regardless of unsolved meta variables"+    , Option []     ["allow-incomplete-matches"] (NoArg allowIncompleteMatchFlag)+                    "succeed and create interface file regardless of incomplete pattern matches"+    , Option []     ["no-positivity-check"] (NoArg noPositivityFlag)+                    "do not warn about not strictly positive data types"+    , Option []     ["no-termination-check"] (NoArg dontTerminationCheckFlag)+                    "do not warn about possibly nonterminating code"+    , Option []     ["termination-depth"] (ReqArg terminationDepthFlag "N")+                    "allow termination checker to count decrease/increase upto N (default N=1)"+    , Option []     ["type-in-type"] (NoArg dontUniverseCheckFlag)+                    "ignore universe levels (this makes Agda inconsistent)"+    , Option []     ["omega-in-omega"] (NoArg omegaInOmegaFlag)+                    "enable typing rule Setω : Setω (this makes Agda inconsistent)"+    , Option []     ["subtyping"] (NoArg subtypingFlag)+                    "enable subtyping rules in general (e.g. for irrelevance and erasure)"+    , Option []     ["no-subtyping"] (NoArg noSubtypingFlag)+                    "disable subtyping rules in general (e.g. for irrelevance and erasure) (default)"+    , Option []     ["cumulativity"] (NoArg cumulativityFlag)+                    "enable subtyping of universes (e.g. Set =< Set₁) (implies --subtyping)"+    , Option []     ["no-cumulativity"] (NoArg noCumulativityFlag)+                    "disable subtyping of universes (default)"+    , Option []     ["prop"] (NoArg propFlag)+                    "enable the use of the Prop universe"+    , Option []     ["no-prop"] (NoArg noPropFlag)+                    "disable the use of the Prop universe (default)"+    , Option []     ["two-level"] (NoArg twoLevelFlag)+                    "enable the use of SSet* universes"+    , Option []     ["sized-types"] (NoArg sizedTypes)+                    "enable sized types (default, inconsistent with --guardedness, implies --subtyping)"+    , Option []     ["no-sized-types"] (NoArg noSizedTypes)+                    "disable sized types"+    , Option []     ["flat-split"] (NoArg flatSplitFlag)+                    "allow split on (@flat x : A) arguments (default)"+    , Option []     ["no-flat-split"] (NoArg noFlatSplitFlag)+                    "disable split on (@flat x : A) arguments"+    , Option []     ["guardedness"] (NoArg guardedness)+                    "enable constructor-based guarded corecursion (default, inconsistent with --sized-types)"+    , Option []     ["no-guardedness"] (NoArg noGuardedness)+                    "disable constructor-based guarded corecursion"+    , Option []     ["injective-type-constructors"] (NoArg injectiveTypeConstructorFlag)+                    "enable injective type constructors (makes Agda anti-classical and possibly inconsistent)"+    , Option []     ["no-universe-polymorphism"] (NoArg noUniversePolymorphismFlag)+                    "disable universe polymorphism"+    , Option []     ["universe-polymorphism"] (NoArg universePolymorphismFlag)+                    "enable universe polymorphism (default)"+    , Option []     ["irrelevant-projections"] (NoArg irrelevantProjectionsFlag)+                    "enable projection of irrelevant record fields and similar irrelevant definitions (inconsistent)"+    , Option []     ["no-irrelevant-projections"] (NoArg noIrrelevantProjectionsFlag)+                    "disable projection of irrelevant record fields and similar irrelevant definitions (default)"+    , Option []     ["experimental-irrelevance"] (NoArg experimentalIrrelevanceFlag)+                    "enable potentially unsound irrelevance features (irrelevant levels, irrelevant data matching)"+    , Option []     ["with-K"] (NoArg withKFlag)+                    "enable the K rule in pattern matching (default)"+    , Option []     ["without-K"] (NoArg withoutKFlag)+                    "disable the K rule in pattern matching"+    , Option []     ["copatterns"] (NoArg copatternsFlag)+                    "enable definitions by copattern matching (default)"+    , Option []     ["no-copatterns"] (NoArg noCopatternsFlag)+                    "disable definitions by copattern matching"+    , Option []     ["no-pattern-matching"] (NoArg noPatternMatchingFlag)+                    "disable pattern matching completely"+    , Option []     ["exact-split"] (NoArg exactSplitFlag)+                    "require all clauses in a definition to hold as definitional equalities (unless marked CATCHALL)"+    , Option []     ["no-exact-split"] (NoArg noExactSplitFlag)+                    "do not require all clauses in a definition to hold as definitional equalities (default)"+    , Option []     ["no-eta-equality"] (NoArg noEtaFlag)+                    "default records to no-eta-equality"+    , Option []     ["no-forcing"] (NoArg noForcingFlag)+                    "disable the forcing analysis for data constructors (optimisation)"+    , Option []     ["no-projection-like"] (NoArg noProjectionLikeFlag)+                    "disable the analysis whether function signatures liken those of projections (optimisation)"+    , Option []     ["rewriting"] (NoArg rewritingFlag)+                    "enable 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)+                    "enable cubical features (e.g. overloads lambdas for paths), implies --without-K"+    , Option []     ["guarded"] (NoArg guardedFlag)+                    "enable @lock/@tick attributes"+    , Option []     ["experimental-lossy-unification"] (NoArg firstOrderFlag)+                    "enable heuristically unifying `f es = f es'` by unifying `es = es'`, even when it could lose solutions."+    , Option []     ["postfix-projections"] (NoArg postfixProjectionsFlag)+                    "make postfix projection notation the default"+    , Option []     ["keep-pattern-variables"] (NoArg keepPatternVariablesFlag)+                    "don't replace variables with dot patterns during case splitting"+    , Option []     ["instance-search-depth"] (ReqArg instanceDepthFlag "N")+                    "set instance search depth to N (default: 500)"+    , Option []     ["overlapping-instances"] (NoArg overlappingInstancesFlag)+                    "consider recursive instance arguments during pruning of instance candidates"+    , Option []     ["no-overlapping-instances"] (NoArg noOverlappingInstancesFlag)+                    "don't consider recursive instance arguments during pruning of instance candidates (default)"+    , Option []     ["qualified-instances"] (NoArg qualifiedInstancesFlag)+                    "use instances with qualified names (default)"+    , Option []     ["no-qualified-instances"] (NoArg noQualifiedInstancesFlag)+                    "don't use instances with qualified names"+    , 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"+    , Option []     ["double-check"] (NoArg (doubleCheckFlag True))+                    "enable double-checking of all terms using the internal typechecker"+    , Option []     ["no-double-check"] (NoArg (doubleCheckFlag False))+                    "disable double-checking of terms (default)"+    , Option []     ["no-syntactic-equality"] (NoArg noSyntacticEqualityFlag)+                    "disable the syntactic equality shortcut in the conversion checker"+    , Option ['W']  ["warning"] (ReqArg warningModeFlag "FLAG")+                    ("set warning flags. See --help=warning.")+    , Option []     ["no-main"] (NoArg compileFlagNoMain)+                    "do not treat the requested module as the main module of a program when compiling"+    , Option []     ["caching"] (NoArg $ cachingFlag True)+                    "enable caching of typechecking (default)"+    , Option []     ["no-caching"] (NoArg $ cachingFlag False)+                    "disable caching of typechecking"+    , Option []     ["count-clusters"] (NoArg countClustersFlag)+                    ("count extended grapheme clusters when " +++                     "generating LaTeX (note that this flag " +++#ifdef COUNT_CLUSTERS+                     "is not enabled in all builds of Agda)"+#else+                     "has not been enabled in this build of Agda)"+#endif+                    )+    , Option []     ["auto-inline"] (NoArg autoInlineFlag)+                    "enable automatic compile-time inlining"+    , Option []     ["no-auto-inline"] (NoArg noAutoInlineFlag)+                    ("disable automatic compile-time inlining (default), " +++                     "only definitions marked INLINE will be inlined")+    , Option []     ["no-print-pattern-synonyms"] (NoArg noPrintPatSynFlag)+                    "expand pattern synonyms when printing terms"+    , Option []     ["no-fast-reduce"] (NoArg noFastReduceFlag)+                    "disable reduction using the Agda Abstract Machine"+    , Option []     ["call-by-name"] (NoArg callByNameFlag)+                    "use call-by-name evaluation instead of call-by-need"+    , Option []     ["no-import-sorts"] (NoArg noImportSorts)+                    "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module"+    , Option []     ["allow-exec"] (NoArg allowExec)+                    "allow system calls to trusted executables with primExec"+    ]++-- | Pragma options of previous versions of Agda.+--   Should not be listed in the usage info, put parsed by GetOpt for good error messaging.+deadPragmaOptions :: [OptDescr (Flag PragmaOptions)]+deadPragmaOptions =+    [ Option []     ["guardedness-preserving-type-constructors"] (NoArg guardingTypeConstructorFlag)+                    "treat type constructors as inductive constructors when checking productivity"+    , Option []     ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)+                    "the option has been removed"+    , Option []     ["no-sort-comparison"] (NoArg noSortComparisonFlag)+                    "disable the comparison of sorts when checking conversion of types"+    ]++-- | Used for printing usage info.+--   Does not include the dead options.+standardOptions_ :: [OptDescr ()]+standardOptions_ = map void standardOptions++-- | Simple interface for System.Console.GetOpt+--   Could be moved to Agda.Utils.Options (does not exist yet)+getOptSimple+  :: [String]               -- ^ command line argument words+  -> [OptDescr (Flag opts)] -- ^ options handlers+  -> (String -> Flag opts)  -- ^ handler of non-options (only one is allowed)+  -> Flag opts              -- ^ combined opts data structure transformer+getOptSimple argv opts fileArg = \ defaults ->+  case getOpt' (ReturnInOrder fileArg) opts argv of+    (o, _, []          , [] )  -> foldl (>>=) (return defaults) o+    (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg++      where+      ucap = "Unrecognized " ++ plural unrecognized "option" ++ ":"+      ecap = plural errs "Option error" ++ ":"+      umsg = if null unrecognized then "" else unlines $+       ucap : map suggest unrecognized+      emsg = if null errs then "" else unlines $+       ecap : errs+      plural [_] x = x+      plural _   x = x ++ "s"++      -- Suggest alternatives that are at most 3 typos away++      longopts :: [String]+      longopts = map ("--" ++) $ 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 -> [[String]]+      alts s = map (map snd) $ groupOn fst $ closeopts s++      suggest :: String -> String+      suggest s = case alts s of+        []     -> s+        as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"++      sugs :: [String] -> String+      sugs [a] = a+      sugs as  = "any of " ++ unwords as++{- No longer used in favour of parseBackendOptions in Agda.Compiler.Backend+-- | Parse the standard options.+parseStandardOptions :: [String] -> OptM CommandLineOptions+parseStandardOptions argv = parseStandardOptions' argv defaultOptions++parseStandardOptions' :: [String] -> Flag CommandLineOptions+parseStandardOptions' argv opts = do+  opts <- getOptSimple (stripRTS argv) (deadStandardOptions ++ standardOptions) inputFlag opts+  checkOpts opts+-}++-- | Parse options from an options pragma.+parsePragmaOptions+  :: [String]+     -- ^ Pragma options.+  -> CommandLineOptions+     -- ^ Command-line options which should be updated.+  -> OptM PragmaOptions+parsePragmaOptions argv opts = do+  ps <- getOptSimple argv (deadPragmaOptions ++ pragmaOptions)+          (\s _ -> throwError $ "Bad option in pragma: " ++ s)+          (optPragmaOptions opts)+  _ <- checkOpts (opts { optPragmaOptions = ps })+  return 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)

+ src/full/Agda/Interaction/Options/HasOptions.hs view

@@ -0,0 +1,39 @@+module Agda.Interaction.Options.HasOptions+  ( HasOptions (pragmaOptions, commandLineOptions)+  ) where++import Control.Monad.Except (ExceptT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.State (StateT)+import Control.Monad.Trans ( MonadTrans, lift )+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Writer (WriterT)++import Agda.Interaction.Options.Base (PragmaOptions, CommandLineOptions)+import Agda.Utils.Update (ChangeT)+import Agda.Utils.ListT (ListT)++class (Functor m, Applicative m, Monad m) => HasOptions m where+  -- | Returns the pragma options which are currently in effect.+  pragmaOptions      :: m PragmaOptions+  -- | Returns the command line options which are currently in effect.+  commandLineOptions :: m CommandLineOptions++  default pragmaOptions :: (HasOptions n, MonadTrans t, m ~ t n) => m PragmaOptions+  pragmaOptions      = lift pragmaOptions++  default commandLineOptions :: (HasOptions n, MonadTrans t, m ~ t n) => m CommandLineOptions+  commandLineOptions = lift commandLineOptions++-- HasOptions lifts through monad transformers+-- (see default signatures in the HasOptions class).++instance HasOptions m => HasOptions (ChangeT m)+instance HasOptions m => HasOptions (ExceptT e m)+instance HasOptions m => HasOptions (IdentityT m)+instance HasOptions m => HasOptions (ListT m)+instance HasOptions m => HasOptions (MaybeT m)+instance HasOptions m => HasOptions (ReaderT r m)+instance HasOptions m => HasOptions (StateT s m)+instance (HasOptions m, Monoid w) => HasOptions (WriterT w m)

src/full/Agda/Interaction/Options/Help.hs view

@@ -7,6 +7,10 @@        , allHelpTopics        ) where +import Control.DeepSeq++import GHC.Generics (Generic)+ import Agda.Interaction.Options.Warnings  -- | Interface to the @help@ function@@ -15,15 +19,19 @@   -- ^ General usage information   | HelpFor HelpTopic   -- ^ Specialised usage information about TOPIC-  deriving (Eq, Show)+  deriving (Eq, Show, Generic) +instance NFData Help+ -- | List of Help Topics -- NOTA BENE: -- You need to add each new topic together with its name to @allHelpTopics@  data HelpTopic   = Warning-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)++instance NFData HelpTopic  allHelpTopics :: [(String, HelpTopic)] allHelpTopics = [("warning", Warning)]

− src/full/Agda/Interaction/Options/IORefs.hs

@@ -1,18 +0,0 @@--- | Some IORefs to access option values in pure code--module Agda.Interaction.Options.IORefs-    ( UnicodeOrAscii(..)-    , unicodeOrAscii-    ) where--import Data.IORef-import qualified System.IO.Unsafe as UNSAFE---- | In `Agda.Syntax.Concrete.Pretty` and `Agda.Utils.String` we want to know--- whether we are allowed to insert unicode characters or not.--data UnicodeOrAscii = UnicodeOk | AsciiOnly--{-# NOINLINE unicodeOrAscii #-}-unicodeOrAscii :: IORef UnicodeOrAscii-unicodeOrAscii = UNSAFE.unsafePerformIO $ newIORef UnicodeOk

src/full/Agda/Interaction/Options/Lenses.hs view

@@ -15,6 +15,7 @@  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.State+import Agda.Interaction.Library (getPrimitiveLibDir) import Agda.Interaction.Options  import Agda.Utils.Lens@@ -45,7 +46,7 @@   setPragmaOptions = set stPragmaOptions   lensPragmaOptions = stPragmaOptions -modifyPragmaOptions :: (PragmaOptions -> PragmaOptions) -> TCM ()+modifyPragmaOptions :: MonadTCState m => (PragmaOptions -> PragmaOptions) -> m () modifyPragmaOptions = modifyTC . mapPragmaOptions  ---------------------------------------------------------------------------@@ -69,10 +70,10 @@   getVerbosity = getVerbosity . getPragmaOptions   mapVerbosity = mapPragmaOptions . mapVerbosity -modifyVerbosity :: (Verbosity -> Verbosity) -> TCM ()+modifyVerbosity :: MonadTCState m => (Verbosity -> Verbosity) -> m () modifyVerbosity = modifyTC . mapVerbosity -putVerbosity :: Verbosity -> TCM ()+putVerbosity :: MonadTCState m => Verbosity -> m () putVerbosity = modifyTC . setVerbosity  ---------------------------------------------------------------------------@@ -96,7 +97,7 @@   getCommandLineOptions = getCommandLineOptions . stPersistentState   mapCommandLineOptions = updatePersistentState . mapCommandLineOptions -modifyCommandLineOptions :: (CommandLineOptions -> CommandLineOptions) -> TCM ()+modifyCommandLineOptions :: MonadTCState m => (CommandLineOptions -> CommandLineOptions) -> m () modifyCommandLineOptions = modifyTC . mapCommandLineOptions  ---------------------------------------------------------------------------@@ -130,10 +131,10 @@   getSafeMode = getSafeMode . getCommandLineOptions   mapSafeMode = mapCommandLineOptions . mapSafeMode -modifySafeMode :: (SafeMode -> SafeMode) -> TCM ()+modifySafeMode :: MonadTCState m => (SafeMode -> SafeMode) -> m () modifySafeMode = modifyTC . mapSafeMode -putSafeMode :: SafeMode -> TCM ()+putSafeMode :: MonadTCState m => SafeMode -> m () putSafeMode = modifyTC . setSafeMode  -- | These builtins may use postulates, and are still considered --safe@@ -160,9 +161,11 @@   , "Agda" </> "Builtin" </> "Int.agda"   , "Agda" </> "Builtin" </> "IO.agda"   , "Agda" </> "Builtin" </> "List.agda"+  , "Agda" </> "Builtin" </> "Maybe.agda"   , "Agda" </> "Builtin" </> "Nat.agda"   , "Agda" </> "Builtin" </> "Reflection.agda"   , "Agda" </> "Builtin" </> "Reflection" </> "Properties.agda"+  , "Agda" </> "Builtin" </> "Reflection" </> "External.agda"   , "Agda" </> "Builtin" </> "Sigma.agda"   , "Agda" </> "Builtin" </> "Size.agda"   , "Agda" </> "Builtin" </> "Strict.agda"@@ -192,14 +195,19 @@ builtinModules = builtinModulesWithSafePostulates `Set.union`                  builtinModulesWithUnsafePostulates -isBuiltinModule :: FilePath -> TCM Bool+isPrimitiveModule :: MonadIO m => FilePath -> m Bool+isPrimitiveModule file = do+  libdirPrim <- liftIO getPrimitiveLibDir+  return (file `Set.member` Set.map (libdirPrim </>) primitiveModules)++isBuiltinModule :: MonadIO m => FilePath -> m Bool isBuiltinModule file = do-  libdirPrim <- (</> "prim") <$> liftIO defaultLibDir+  libdirPrim <- liftIO getPrimitiveLibDir   return (file `Set.member` Set.map (libdirPrim </>) builtinModules) -isBuiltinModuleWithSafePostulates :: FilePath -> TCM Bool+isBuiltinModuleWithSafePostulates :: MonadIO m => FilePath -> m Bool isBuiltinModuleWithSafePostulates file = do-  libdirPrim <- (</> "prim") <$> liftIO defaultLibDir+  libdirPrim <- liftIO getPrimitiveLibDir   let safeBuiltins   = Set.map (libdirPrim </>) builtinModulesWithSafePostulates   return (file `Set.member` safeBuiltins) @@ -240,16 +248,16 @@   getAbsoluteIncludePaths = getAbsoluteIncludePaths . getCommandLineOptions   mapAbsoluteIncludePaths = mapCommandLineOptions . mapAbsoluteIncludePaths -modifyIncludePaths :: ([FilePath] -> [FilePath]) -> TCM ()+modifyIncludePaths :: MonadTCState m => ([FilePath] -> [FilePath]) -> m () modifyIncludePaths = modifyTC . mapIncludePaths -putIncludePaths :: [FilePath] -> TCM ()+putIncludePaths :: MonadTCState m => [FilePath] -> m () putIncludePaths = modifyTC . setIncludePaths -modifyAbsoluteIncludePaths :: ([AbsolutePath] -> [AbsolutePath]) -> TCM ()+modifyAbsoluteIncludePaths :: MonadTCState m => ([AbsolutePath] -> [AbsolutePath]) -> m () modifyAbsoluteIncludePaths = modifyTC . mapAbsoluteIncludePaths -putAbsoluteIncludePaths :: [AbsolutePath] -> TCM ()+putAbsoluteIncludePaths :: MonadTCState m => [AbsolutePath] -> m () putAbsoluteIncludePaths = modifyTC . setAbsoluteIncludePaths  ---------------------------------------------------------------------------@@ -282,8 +290,8 @@   getPersistentVerbosity = getPersistentVerbosity . getCommandLineOptions   mapPersistentVerbosity = mapCommandLineOptions . mapPersistentVerbosity -modifyPersistentVerbosity :: (PersistentVerbosity -> PersistentVerbosity) -> TCM ()+modifyPersistentVerbosity :: MonadTCState m => (PersistentVerbosity -> PersistentVerbosity) -> m () modifyPersistentVerbosity = modifyTC . mapPersistentVerbosity -putPersistentVerbosity :: PersistentVerbosity -> TCM ()+putPersistentVerbosity :: MonadTCState m => PersistentVerbosity -> m () putPersistentVerbosity = modifyTC . setPersistentVerbosity

src/full/Agda/Interaction/Options/Warnings.hs view

@@ -12,6 +12,8 @@        , incompleteMatchWarnings        , errorWarnings        , defaultWarningMode+       , WarningModeError(..)+       , prettyWarningModeError        , warningModeUpdate        , warningSets        , WarningName (..)@@ -22,15 +24,18 @@ where  import Control.Arrow ( (&&&) )-import Control.Monad ( guard )+import Control.DeepSeq+import Control.Monad ( guard, when )  import Text.Read ( readMaybe ) import Data.Set (Set) import qualified Data.Set as Set-import Data.Maybe ( fromMaybe ) import Data.List ( stripPrefix, intercalate ) +import GHC.Generics (Generic)+ import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.Maybe  import Agda.Utils.Impossible@@ -41,8 +46,10 @@ data WarningMode = WarningMode   { _warningSet :: Set WarningName   , _warn2Error :: Bool-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic) +instance NFData WarningMode+ warningSet :: Lens' (Set WarningName) WarningMode warningSet f o = (\ ws -> o { _warningSet = ws }) <$> f (_warningSet o) @@ -59,19 +66,37 @@ defaultWarningMode = WarningMode ws False where   ws = fst $ fromMaybe __IMPOSSIBLE__ $ lookup defaultWarningSet warningSets +-- | Some warnings are errors and cannot be turned off.+data WarningModeError = Unknown String | NoNoError String++prettyWarningModeError :: WarningModeError -> String+prettyWarningModeError = \case+  Unknown str -> concat [ "Unknown warning flag: ", str, "." ]+  NoNoError str -> concat [ "You may only turn off benign warnings. The warning "+                          , str+                          ," is a non-fatal error and thus cannot be ignored." ]++-- | From user-given directives we compute WarningMode updates+type WarningModeUpdate = WarningMode -> WarningMode+ -- | @warningModeUpdate str@ computes the action of @str@ over the current -- @WarningMode@: it may reset the set of warnings, add or remove a specific -- flag or demand that any warning be turned into an error -warningModeUpdate :: String -> Maybe (WarningMode -> WarningMode)+warningModeUpdate :: String -> Either WarningModeError WarningModeUpdate warningModeUpdate str = case str of-  "error"   -> Just $ set warn2Error True-  "noerror" -> Just $ set warn2Error False+  "error"   -> pure $ set warn2Error True+  "noerror" -> pure $ set warn2Error False   _ | Just ws <- fst <$> lookup str warningSets-            -> Just $ set warningSet ws+            -> pure $ set warningSet ws   _ -> case stripPrefix "no" str of-    Just str' -> (over warningSet . Set.delete) <$> string2WarningName str'-    Nothing   -> (over warningSet . Set.insert) <$> string2WarningName str+    Nothing   -> do+      wname <- maybe (Left (Unknown str)) Right (string2WarningName str)+      pure (over warningSet $ Set.insert wname)+    Just str' -> do+      wname <- maybe (Left (Unknown str')) Right (string2WarningName str')+      when (wname `elem` errorWarnings) (Left (NoNoError str'))+      pure (over warningSet $ Set.delete wname)  -- | Common sets of warnings @@ -122,6 +147,10 @@   , CoInfectiveImport_   , RewriteNonConfluent_   , RewriteMaybeNonConfluent_+  , RewriteAmbiguousRules_+  , RewriteMissingRule_+  , ExeNotFoundWarning_+  , ExeNotExecutableWarning_   ]  allWarnings :: Set WarningName@@ -141,10 +170,13 @@   =   -- Parser Warnings     OverlappingTokensWarning_+  | UnsupportedAttribute_+  | MultipleAttributes_   -- Library Warnings   | LibUnknownField_   -- Nicifer Warnings   | EmptyAbstract_+  | EmptyConstructor_   | EmptyField_   | EmptyGeneralize_   | EmptyInstance_@@ -154,10 +186,14 @@   | EmptyPrimitive_   | EmptyPrivate_   | EmptyRewritePragma_+  | EmptyWhere_   | InvalidCatchallPragma_+  | InvalidConstructor_+  | InvalidConstructorBlock_   | InvalidCoverageCheckPragma_   | InvalidNoPositivityCheckPragma_   | InvalidNoUniverseCheckPragma_+  | InvalidRecordDirective_   | InvalidTerminationCheckPragma_   | MissingDefinitions_   | NotAllowedInMutual_@@ -175,13 +211,16 @@   | UselessPrivate_   -- Scope and Type Checking Warnings   | AbsurdPatternRequiresNoRHS_+  | AsPatternShadowsConstructorOrPatternSynonym_   | CantGeneralizeOverSorts_   | ClashesViaRenaming_                -- issue #4154   | CoverageIssue_   | CoverageNoExactSplit_   | DeprecationWarning_+  | DuplicateUsing_   | FixityInRenamingModule_   | GenericNonFatalError_+  | GenericUseless_   | GenericWarning_   | IllformedAsClause_   | InstanceArgWithExplicitArg_@@ -189,12 +228,15 @@   | InstanceNoOutputTypeName_   | InversionDepthReached_   | ModuleDoesntExport_+  | NoGuardednessFlag_   | NotInScope_   | NotStrictlyPositive_   | OldBuiltin_   | PragmaCompileErased_   | RewriteMaybeNonConfluent_   | RewriteNonConfluent_+  | RewriteAmbiguousRules_+  | RewriteMissingRule_   | SafeFlagEta_   | SafeFlagInjective_   | SafeFlagNoCoverageCheck_@@ -211,7 +253,9 @@   | UnsolvedConstraints_   | UnsolvedInteractionMetas_   | UnsolvedMetaVariables_+  | UselessHiding_   | UselessInline_+  | UselessPatternDeclarationForRecord_   | UselessPublic_   | UserWarning_   | WithoutKFlagPrimEraseEquality_@@ -219,8 +263,16 @@   -- Checking consistency of options   | CoInfectiveImport_   | InfectiveImport_-  deriving (Eq, Ord, Show, Read, Enum, Bounded)+  -- Record field warnings+  | DuplicateFieldsWarning_+  | TooManyFieldsWarning_+  -- System call warnings+  | ExeNotFoundWarning_+  | ExeNotExecutableWarning_+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) +instance NFData WarningName+ -- | The flag corresponding to a warning is precisely the name of the constructor -- minus the trailing underscore. @@ -229,7 +281,7 @@ string2WarningName = readMaybe . (++ "_")  warningName2String :: WarningName -> String-warningName2String = init . show+warningName2String = initWithDefault __IMPOSSIBLE__ . show  -- | @warningUsage@ generated using @warningNameDescription@ @@ -244,7 +296,7 @@     \ one of the following:"   , ""   , untable (fmap (fst &&& snd . snd) warningSets)-  , "Individual warnings can be turned on and off by -W Name and\+  , "Individual benign warnings can be turned on and off by -W Name and\     \ -W noName, respectively, where Name comes from the following\     \ list (warnings marked with 'd' are turned on by default, and 'b'\     \ stands for \"benign warning\"):"@@ -271,13 +323,16 @@ -- Leave String empty to skip that name.  warningNameDescription :: WarningName -> String-warningNameDescription w = case w of+warningNameDescription = \case   -- Parser Warnings   OverlappingTokensWarning_        -> "Multi-line comments spanning one or more literate text blocks."+  UnsupportedAttribute_            -> "Unsupported attributes."+  MultipleAttributes_              -> "Multiple attributes."   -- Library Warnings   LibUnknownField_                 -> "Unknown field in library file."   -- Nicifer Warnings   EmptyAbstract_                   -> "Empty `abstract' blocks."+  EmptyConstructor_                -> "Empty `constructor' blocks."   EmptyField_                      -> "Empty `field` blocks."   EmptyGeneralize_                 -> "Empty `variable' blocks."   EmptyInstance_                   -> "Empty `instance' blocks."@@ -287,10 +342,14 @@   EmptyPrimitive_                  -> "Empty `primitive' blocks."   EmptyPrivate_                    -> "Empty `private' blocks."   EmptyRewritePragma_              -> "Empty `REWRITE' pragmas."+  EmptyWhere_                      -> "Empty `where' blocks."   InvalidCatchallPragma_           -> "`CATCHALL' pragmas before a non-function clause."+  InvalidConstructor_              -> "`constructor' blocks may only contain type signatures for constructors."+  InvalidConstructorBlock_         -> "No `constructor' blocks outside of `interleaved mutual' blocks."   InvalidCoverageCheckPragma_      -> "Coverage checking pragmas before non-function or `mutual' blocks."   InvalidNoPositivityCheckPragma_  -> "No positivity checking pragmas before non-`data', `record' or `mutual' blocks."   InvalidNoUniverseCheckPragma_    -> "No universe checking pragmas before non-`data' or `record' declaration."+  InvalidRecordDirective_          -> "No record directive outside of record definition / below field declarations."   InvalidTerminationCheckPragma_   -> "Termination checking pragmas before non-function or `mutual' blocks."   MissingDefinitions_              -> "Declarations not associated to a definition."   NotAllowedInMutual_              -> "Declarations not allowed in a mutual block."@@ -304,32 +363,40 @@   UnknownNamesInFixityDecl_        -> "Names not declared in the same scope as their syntax or fixity declaration."   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."   UselessInline_                   -> "`INLINE' pragmas where they have no effect."   UselessInstance_                 -> "`instance' blocks where they have no effect."   UselessPrivate_                  -> "`private' blocks where they have no effect."   UselessPublic_                   -> "`public' blocks where they have no effect."+  UselessPatternDeclarationForRecord_ -> "`pattern' attributes where they have no effect."   -- Scope and Type Checking Warnings   AbsurdPatternRequiresNoRHS_      -> "A clause with an absurd pattern does not need a Right Hand Side."+  AsPatternShadowsConstructorOrPatternSynonym_ -> "@-patterns that shadow constructors or pattern synonyms."   CantGeneralizeOverSorts_         -> "Attempt to generalize over sort metas in 'variable' declaration."   ClashesViaRenaming_              -> "Clashes introduced by `renaming'."  -- issue #4154   CoverageIssue_                   -> "Failed coverage checks."   CoverageNoExactSplit_            -> "Failed exact split checks."   DeprecationWarning_              -> "Feature deprecation."   GenericNonFatalError_            -> ""+  GenericUseless_                  -> "Useless code."   GenericWarning_                  -> ""   IllformedAsClause_               -> "Illformed `as'-clauses in `import' statements."   InstanceNoOutputTypeName_        -> "instance arguments whose type does not end in a named or variable type are never considered by instance search."   InstanceArgWithExplicitArg_      -> "instance arguments with explicit arguments are never considered by instance search."   InstanceWithExplicitArg_         -> "`instance` declarations with explicit arguments are never considered by instance search."   InversionDepthReached_           -> "Inversions of pattern-matching failed due to exhausted inversion depth."+  NoGuardednessFlag_               -> "Coinductive record but no --guardedness flag."   ModuleDoesntExport_              -> "Imported name is not actually exported."+  DuplicateUsing_                  -> "Repeated names in using directive."   FixityInRenamingModule_          -> "Found fixity annotation in renaming directive for module."-  NotInScope_                      -> "Out of scope name"+  NotInScope_                      -> "Out of scope name."   NotStrictlyPositive_             -> "Failed strict positivity checks."   OldBuiltin_                      -> "Deprecated `BUILTIN' pragmas."   PragmaCompileErased_             -> "`COMPILE' pragma targeting an erased symbol."-  RewriteMaybeNonConfluent_      -> "Failed confluence checks while computing overlap."-  RewriteNonConfluent_           -> "Failed confluence checks while joining critical pairs."+  RewriteMaybeNonConfluent_        -> "Failed local confluence check while computing overlap."+  RewriteNonConfluent_             -> "Failed local confluence check while joining critical pairs."+  RewriteAmbiguousRules_           -> "Failed global confluence check because of overlapping rules."+  RewriteMissingRule_              -> "Failed global confluence check because of missing rule."   SafeFlagEta_                     -> "`ETA' pragmas with the safe flag."   SafeFlagInjective_               -> "`INJECTIVE' pragmas with the safe flag."   SafeFlagNoCoverageCheck_         -> "`NON_COVERING` pragmas with the safe flag."@@ -352,3 +419,9 @@   -- Checking consistency of options   CoInfectiveImport_               -> "Importing a file not using e.g. `--safe'  from one which does."   InfectiveImport_                 -> "Importing a file using e.g. `--cubical' into one which doesn't."+  -- Record field warnings+  DuplicateFieldsWarning_          -> "Record expression with duplicate field names."+  TooManyFieldsWarning_            -> "Record expression with invalid field names."+  -- System call warnings+  ExeNotFoundWarning_              -> "Trusted executable cannot be found."+  ExeNotExecutableWarning_         -> "Trusted executable does not have permission to execute."

src/full/Agda/Interaction/Response.hs view

@@ -37,7 +37,6 @@ import Control.Monad.Trans import Data.Int import System.IO-import Agda.Utils.Pretty (Doc)  -- | Responses for any interactive interface --@@ -154,6 +153,8 @@ data Status = Status   { sShowImplicitArguments :: Bool     -- ^ Are implicit arguments displayed?+  , sShowIrrelevantArguments :: Bool+    -- ^ Are irrelevant arguments displayed?   , sChecked               :: Bool     -- ^ Has the module been successfully type checked?   }@@ -193,7 +194,7 @@ -- things to stdout (other things generate internal errors).  defaultInteractionOutputCallback :: InteractionOutputCallback-defaultInteractionOutputCallback r = case r of+defaultInteractionOutputCallback = \case   Resp_HighlightingInfo {}  -> __IMPOSSIBLE__   Resp_Status {}            -> __IMPOSSIBLE__   Resp_JumpToError {}       -> __IMPOSSIBLE__

src/full/Agda/Interaction/SearchAbout.hs view

@@ -20,6 +20,7 @@ import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Internal as I +import Agda.Utils.List   ( initLast1  ) import Agda.Utils.Pretty ( prettyShow )  findMentions :: Rewrite -> Range -> String -> ScopeM [(C.Name, I.Type)]@@ -60,13 +61,14 @@   return $ concat ress    where+    isString :: String -> Either String String+    isString ('"' : c : cs)+      | (str, '"') <- initLast1 c cs+      = Left $ filter (/= '"') str     isString str-      |  not (null str)-      && head str == '"'-      && last str == '"' = Left $ filter (/= '"') str-      | otherwise        = Right str+      = Right str -    anames (DefinedName _ an)     = [an]+    anames (DefinedName _ an _)   = [an]     anames (FieldName     ans)    = toList ans-    anames (ConstructorName ans)  = toList ans+    anames (ConstructorName _ ans)= toList ans     anames _                      = []

src/full/Agda/Main.hs view

@@ -3,26 +3,26 @@ -} module Agda.Main where -import Control.Monad.State+import Prelude hiding (null) +import Control.Monad.Except++import qualified Data.List as List import Data.Maybe  import System.Environment-import System.Exit import System.Console.GetOpt +import Paths_Agda            ( getDataDir )+ import Agda.Interaction.CommandLine+import Agda.Interaction.ExitCode (AgdaError(..), exitSuccess, exitAgdaWith) import Agda.Interaction.Options import Agda.Interaction.Options.Help (Help (..))-import Agda.Interaction.Monad import Agda.Interaction.EmacsTop (mimicGHCi) import Agda.Interaction.JSONTop (jsonREPL)-import Agda.Interaction.Imports (MaybeWarnings'(..)) import Agda.Interaction.FindFile ( SourceFile(SourceFile) ) import qualified Agda.Interaction.Imports as Imp-import qualified Agda.Interaction.Highlighting.Dot as Dot-import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX-import Agda.Interaction.Highlighting.HTML  import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench@@ -30,74 +30,141 @@ import Agda.TypeChecking.Warnings import Agda.TypeChecking.Pretty -import Agda.Compiler.MAlonzo.Compiler (ghcBackend)-import Agda.Compiler.JS.Compiler (jsBackend)- import Agda.Compiler.Backend--import Agda.Utils.Monad-import Agda.Utils.String+import Agda.Compiler.Builtin  import Agda.VersionCommit +import Agda.Utils.FileName (absolute, filePath, AbsolutePath)+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.String import qualified Agda.Utils.Benchmark as UtilsBench-import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.Impossible -builtinBackends :: [Backend]-builtinBackends = [ ghcBackend, jsBackend ]+import Agda.Utils.Impossible  -- | The main function runAgda :: [Backend] -> IO () runAgda backends = runAgda' $ builtinBackends ++ backends +-- | The main function without importing built-in backends runAgda' :: [Backend] -> IO ()-runAgda' backends = runTCMPrettyErrors $ do-  progName <- liftIO getProgName-  argv     <- liftIO getArgs-  opts     <- liftIO $ runOptM $ parseBackendOptions backends argv defaultOptions-  case opts of-    Left  err        -> liftIO $ optionError err-    Right (bs, opts) -> do-      setTCLens stBackends bs-      let enabled (Backend b) = isEnabled b (options b)-          bs' = filter enabled bs-      () <$ runAgdaWithOptions backends generateHTML (interaction bs') progName opts-      where-        interaction bs = backendInteraction bs $ defaultInteraction opts+runAgda' backends = do+  progName <- getProgName+  argv     <- getArgs+  conf     <- runExceptT $ do+    (bs, opts) <- ExceptT $ runOptM $ parseBackendOptions backends argv defaultOptions+    -- The absolute path of the input file, if provided+    inputFile <- liftIO $ mapM absolute $ optInputFile opts+    mode      <- getMainMode bs inputFile opts+    return (bs, opts, mode) -defaultInteraction :: CommandLineOptions -> TCM (Maybe Interface) -> TCM ()-defaultInteraction opts-  | i         = runIM . interactionLoop-  | ghci      = mimicGHCi . (failIfInt =<<)-  | json      = jsonREPL . (failIfInt =<<)-  | otherwise = (() <$)-  where-    i    = optInteractive     opts-    ghci = optGHCiInteraction opts-    json = optJSONInteraction opts+  case conf of+    Left err -> optionError err+    Right (bs, opts, mode) -> case mode of+      MainModePrintHelp hp   -> printUsage bs hp+      MainModePrintVersion   -> printVersion bs+      MainModePrintAgdaDir   -> printAgdaDir+      MainModeRun interactor -> runTCMPrettyErrors $ do+        setTCLens stBackends bs+        runAgdaWithOptions interactor progName opts -    failIfInt Nothing  = return ()-    failIfInt (Just _) = __IMPOSSIBLE__+-- | Main execution mode+data MainMode+  = MainModeRun (Interactor ())+  | MainModePrintHelp Help+  | MainModePrintVersion+  | MainModePrintAgdaDir +-- | Determine the main execution mode to run, based on the configured backends and command line options.+-- | This is pure.+getMainMode :: MonadError String m => [Backend] -> Maybe AbsolutePath -> CommandLineOptions -> m MainMode+getMainMode configuredBackends maybeInputFile opts+  | Just hp <- optPrintHelp opts = return $ MainModePrintHelp hp+  | optPrintVersion opts         = return $ MainModePrintVersion+  | optPrintAgdaDir opts         = return $ MainModePrintAgdaDir+  | otherwise                    = do+      mi <- getInteractor configuredBackends maybeInputFile opts+      -- If there was no selection whatsoever (e.g. just invoked "agda"), we just show help and exit.+      return $ maybe (MainModePrintHelp GeneralHelp) MainModeRun mi --- | Run Agda with parsed command line options and with a custom HTML generator+type Interactor a+    -- Setup/initialization action.+    -- This is separated so that errors can be reported in the appropriate format.+    = TCM ()+    -- Type-checking action+    -> (AbsolutePath -> TCM CheckResult)+    -- Main transformed action.+    -> TCM a++data FrontendType+  = FrontEndEmacs+  | FrontEndJson+  | FrontEndRepl++-- Emacs mode. Note that it ignores the "check" action because it calls typeCheck directly.+emacsModeInteractor :: Interactor ()+emacsModeInteractor setup _check = mimicGHCi setup++-- JSON mode. Note that it ignores the "check" action because it calls typeCheck directly.+jsonModeInteractor :: Interactor ()+jsonModeInteractor setup _check = jsonREPL setup++-- The deprecated repl mode.+replInteractor :: Maybe AbsolutePath -> Interactor ()+replInteractor = runInteractionLoop++-- The interactor to use when there are no frontends or backends specified.+defaultInteractor :: AbsolutePath -> Interactor ()+defaultInteractor file setup check = do setup; void $ check file++getInteractor :: MonadError String m => [Backend] -> Maybe AbsolutePath -> CommandLineOptions -> m (Maybe (Interactor ()))+getInteractor configuredBackends maybeInputFile opts =+  case (maybeInputFile, enabledFrontends, enabledBackends) of+    (Just inputFile, [],             _:_) -> return $ Just $ backendInteraction inputFile enabledBackends+    (Just inputFile, [],              []) -> return $ Just $ defaultInteractor inputFile+    (Nothing,        [],              []) -> return Nothing -- No backends, frontends, or input files specified.+    (Nothing,        [],             _:_) -> throwError $ concat ["No input file specified for ", enabledBackendNames]+    (_,              _:_,            _:_) -> throwError $ concat ["Cannot mix ", enabledFrontendNames, " with ", enabledBackendNames]+    (_,              _:_:_,           []) -> throwError $ concat ["Must not specify multiple ", enabledFrontendNames]+    (_,              [fe],            []) | optOnlyScopeChecking opts -> errorFrontendScopeChecking fe+    (_,              [FrontEndRepl],  []) -> return $ Just $ replInteractor maybeInputFile+    (Nothing,        [FrontEndEmacs], []) -> return $ Just $ emacsModeInteractor+    (Nothing,        [FrontEndJson],  []) -> return $ Just $ jsonModeInteractor+    (Just inputFile, [FrontEndEmacs], []) -> errorFrontendFileDisallowed inputFile FrontEndEmacs+    (Just inputFile, [FrontEndJson],  []) -> errorFrontendFileDisallowed inputFile FrontEndJson+  where+    -- NOTE: The notion of a backend being "enabled" *just* refers to this top-level interaction mode selection. The+    -- interaction/interactive front-ends may still invoke available backends even if they are not "enabled".+    isBackendEnabled (Backend b) = isEnabled b (options b)+    enabledBackends = filter isBackendEnabled configuredBackends+    enabledFrontends = concat+      [ [ FrontEndRepl  | optInteractive     opts ]+      , [ FrontEndEmacs | optGHCiInteraction opts ]+      , [ FrontEndJson  | optJSONInteraction opts ]+      ]+    -- Constructs messages like "(no backend)", "backend ghc", "backends (ghc, ocaml)"+    pluralize w []  = concat ["(no ", w, ")"]+    pluralize w [x] = concat [w, " ", x]+    pluralize w xs  = concat [w, "s (", List.intercalate ", " xs, ")"]+    enabledBackendNames  = pluralize "backend" [ backendName b | Backend b <- enabledBackends ]+    enabledFrontendNames = pluralize "frontend" (frontendFlagName <$> enabledFrontends)+    frontendFlagName = ("--" ++) . \case+      FrontEndEmacs -> "interaction"+      FrontEndJson -> "interaction-json"+      FrontEndRepl -> "interactive"+    errorFrontendScopeChecking fe = throwError $+      concat ["The --only-scope-checking flag cannot be combined with ", frontendFlagName fe]+    errorFrontendFileDisallowed inputFile fe = throwError $+      concat ["Must not specify an input file (", filePath inputFile, ") with ", frontendFlagName fe]++-- | Run Agda with parsed command line options runAgdaWithOptions-  :: [Backend]          -- ^ Backends only for printing usage and version information-  -> TCM ()             -- ^ HTML generating action-  -> (TCM (Maybe Interface) -> TCM a) -- ^ Backend interaction+  :: Interactor a       -- ^ Backend interaction   -> String             -- ^ program name   -> CommandLineOptions -- ^ parsed command line options-  -> TCM (Maybe a)-runAgdaWithOptions backends generateHTML interaction progName opts-      | Just hp <- optShowHelp opts = Nothing <$ liftIO (printUsage backends hp)-      | optShowVersion opts         = Nothing <$ liftIO (printVersion backends)-      | isNothing (optInputFile opts)-          && not (optInteractive opts)-          && not (optGHCiInteraction opts)-          && not (optJSONInteraction opts)-                            = Nothing <$ liftIO (printUsage backends GeneralHelp)-      | otherwise           = do+  -> TCM a+runAgdaWithOptions interactor progName opts = do           -- Main function.           -- Bill everything to root of Benchmark trie.           UtilsBench.setBenchmarking UtilsBench.BenchmarkOn@@ -106,57 +173,45 @@             -- on e.g. LaTeX-code generation.             -- Benchmarking might be turned off later by setCommandlineOptions -          Bench.billTo [] checkFile `finally_` do-+          Bench.billTo [] $+            interactor initialSetup checkFile+          `finally_` do             -- Print benchmarks.             Bench.print              -- Print accumulated statistics.             printStatistics 1 Nothing =<< useTC lensAccumStatistics   where-    checkFile = Just <$> do-      when (optInteractive opts) $ liftIO $ putStr splashScreen-      interaction $ do-        setCommandLineOptions opts-        hasFile <- hasInputFile+    -- Options are fleshed out here so that (most) errors like+    -- "bad library path" are validated within the interactor,+    -- so that they are reported with the appropriate protocol/formatting.+    initialSetup :: TCM ()+    initialSetup = do+      opts <- addTrustedExecutables opts+      setCommandLineOptions opts++    checkFile :: AbsolutePath -> TCM CheckResult+    checkFile inputFile = do         -- Andreas, 2013-10-30 The following 'resetState' kills the         -- verbosity options.  That does not make sense (see fail/Issue641).         -- 'resetState' here does not seem to serve any purpose,         -- thus, I am removing it.         -- resetState-        if not hasFile then return Nothing else do           let mode = if optOnlyScopeChecking opts                      then Imp.ScopeCheck                      else Imp.TypeCheck -          file    <- SourceFile <$> getInputFile-          (i, mw) <- Imp.typeCheckMain file mode =<< Imp.sourceInfo file+          result <- Imp.typeCheckMain mode =<< Imp.parseSource (SourceFile inputFile) -          -- An interface is only generated if the mode is-          -- Imp.TypeCheck and there are no warnings.-          result <- case (mode, mw) of-            (Imp.ScopeCheck, _)  -> return Nothing-            (_, NoWarnings)      -> return $ Just i-            (_, SomeWarnings ws) -> do-              ws' <- applyFlagsToTCWarnings ws-              case ws' of-                []   -> return Nothing-                cuws -> tcWarningsToError cuws+          unless (crMode result == ModuleScopeChecked) $+            unlessNullM (applyFlagsToTCWarnings (crWarnings result)) $ \ ws ->+              typeError $ NonFatalErrors ws +          let i = crInterface result           reportSDoc "main" 50 $ pretty i -          whenM (optGenerateHTML <$> commandLineOptions) $-            generateHTML--          whenM (isJust . optDependencyGraph <$> commandLineOptions) $-            Dot.generateDot $ i--          whenM (optGenerateLaTeX <$> commandLineOptions) $-            LaTeX.generateLaTeX i-           -- Print accumulated warnings-          ws <- tcWarnings . classifyWarnings <$> Imp.getAllWarnings AllWarnings-          unless (null ws) $ do+          unlessNullM (tcWarnings . classifyWarnings <$> getAllWarnings AllWarnings) $ \ ws -> do             let banner = text $ "\n" ++ delimiter "All done; warnings encountered"             reportSDoc "warning" 1 $               vcat $ punctuate "\n" $ banner : (prettyTCM <$> ws)@@ -175,7 +230,7 @@ backendUsage :: Backend -> String backendUsage (Backend b) =   usageInfo ("\n" ++ backendName b ++ " backend options") $-    map (fmap $ const ()) (commandLineFlags b)+    map void (commandLineFlags b)  -- | Print version information. printVersion :: [Backend] -> IO ()@@ -185,29 +240,28 @@     [ "  - " ++ name ++ " backend version " ++ ver     | Backend Backend'{ backendName = name, backendVersion = Just ver } <- backends ] +printAgdaDir :: IO ()+printAgdaDir = putStrLn =<< getDataDir+ -- | What to do for bad options. optionError :: String -> IO () optionError err = do   prog <- getProgName   putStrLn $ "Error: " ++ err ++ "\nRun '" ++ prog ++ " --help' for help on command line options."-  exitFailure+  exitAgdaWith OptionError  -- | Run a TCM action in IO; catch and pretty print errors. runTCMPrettyErrors :: TCM () -> IO () runTCMPrettyErrors tcm = do     r <- runTCMTop $ tcm `catchError` \err -> do-      s2s <- prettyTCWarnings' =<< Imp.getAllWarningsOfTCErr err+      s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err       s1  <- prettyError err       let ss = filter (not . null) $ s2s ++ [s1]       unless (null s1) (liftIO $ putStr $ unlines ss)       throwError err     case r of       Right _ -> exitSuccess-      Left _  -> exitFailure+      Left _  -> exitAgdaWith TCMError   `catchImpossible` \e -> do     putStr $ show e-    exitFailure---- | Main-main :: IO ()-main = runAgda []+    exitAgdaWith ImpossibleError

− src/full/Agda/Main.hs-boot

@@ -1,5 +0,0 @@-module Agda.Main where--import {-# SOURCE #-} Agda.Compiler.Backend--builtinBackends :: [Backend]

src/full/Agda/Syntax/Abstract.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-| The abstract syntax. This is what you get after desugaring and scope     analysis of the concrete syntax. The type checker works on abstract syntax,@@ -11,13 +8,15 @@     , module Agda.Syntax.Abstract.Name     ) where -import Prelude-import Control.Arrow (first)--, second, (***))+import Prelude hiding (null) -import Data.Foldable (Foldable)+import Control.DeepSeq++import Data.Bifunctor import qualified Data.Foldable as Fold import Data.Function (on) import Data.Map (Map)+import qualified Data.Map as Map import Data.Maybe import Data.Sequence (Seq, (<|), (><)) import qualified Data.Sequence as Seq@@ -25,12 +24,12 @@ import Data.Set (Set) import Data.Void import Data.Data (Data)-import Data.Monoid (mappend) +import GHC.Generics (Generic)+ import Agda.Syntax.Concrete (FieldAssignment'(..), exprFieldA)--, HoleContent'(..)) import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Abstract.Name-import Agda.Syntax.Abstract.Name as A (QNamed) import qualified Agda.Syntax.Internal as I import Agda.Syntax.Common import Agda.Syntax.Info@@ -40,8 +39,10 @@  import Agda.TypeChecking.Positivity.Occurrence -import Agda.Utils.Geniplate import Agda.Utils.Lens+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null import Agda.Utils.Pretty  import Agda.Utils.Impossible@@ -55,7 +56,7 @@ -- e.g. in @{_ : A} -> ..@ vs. @{r : A} -> ..@.  newtype BindName = BindName { unBind :: Name }-  deriving (Show, Data, HasRange, KillRange, SetRange)+  deriving (Show, Data, HasRange, KillRange, SetRange, NFData)  mkBindName :: Name -> BindName mkBindName x = BindName x@@ -75,12 +76,13 @@ -- | Expressions after scope checking (operators parsed, names resolved). data Expr   = Var  Name                          -- ^ Bound variable.-  | Def  QName                         -- ^ Constant: axiom, function, data or record type.+  | Def'  QName Suffix                 -- ^ Constant: axiom, function, data or record type,+                                       --   with a possible suffix.   | Proj ProjOrigin AmbiguousQName     -- ^ Projection (overloaded).   | Con  AmbiguousQName                -- ^ Constructor (overloaded).   | PatternSyn AmbiguousQName          -- ^ Pattern synonym.   | Macro QName                        -- ^ Macro.-  | Lit Literal                        -- ^ Literal.+  | Lit ExprInfo Literal               -- ^ Literal.   | QuestionMark MetaInfo InteractionId     -- ^ Meta variable for interaction.     --   The 'InteractionId' is usually identical with the@@ -95,13 +97,12 @@   | WithApp ExprInfo Expr [Expr]       -- ^ With application.   | Lam  ExprInfo LamBinding Expr      -- ^ @λ bs → e@.   | AbsurdLam ExprInfo Hiding          -- ^ @λ()@ or @λ{}@.-  | ExtendedLam ExprInfo DefInfo QName [Clause]-  | Pi   ExprInfo Telescope Expr       -- ^ Dependent function space @Γ → A@.-  | Generalized (Set.Set QName) Expr   -- ^ Like a Pi, but the ordering is not known+  | ExtendedLam ExprInfo DefInfo Erased QName (List1 Clause)+  | Pi   ExprInfo Telescope1 Expr      -- ^ Dependent function space @Γ → A@.+  | Generalized (Set QName) Expr       -- ^ Like a Pi, but the ordering is not known   | Fun  ExprInfo (Arg Expr) Expr      -- ^ Non-dependent function space.-  | Set  ExprInfo Integer              -- ^ @Set@, @Set1@, @Set2@, ...-  | Prop ExprInfo Integer              -- ^ @Prop@, @Prop1@, @Prop2@, ...-  | Let  ExprInfo [LetBinding] Expr    -- ^ @let bs in e@.+  | Let  ExprInfo (List1 LetBinding) Expr+                                       -- ^ @let bs in e@.   | ETel Telescope                     -- ^ Only used when printing telescopes.   | Rec  ExprInfo RecordAssigns        -- ^ Record construction.   | RecUpdate ExprInfo Expr Assigns    -- ^ Record update.@@ -112,12 +113,16 @@   | Tactic ExprInfo Expr [NamedArg Expr]                                        -- ^ @tactic e x1 .. xn@   | DontCare Expr                      -- ^ For printing @DontCare@ from @Syntax.Internal@.-  deriving (Data, Show)+  deriving (Data, Show, Generic) +-- | Pattern synonym for regular Def+pattern Def :: QName -> Expr+pattern Def x = Def' x NoSuffix+ -- | Smart constructor for Generalized-generalized :: Set.Set QName -> Expr -> Expr+generalized :: Set QName -> Expr -> Expr generalized s e-    | Set.null s = e+    | null s    = e     | otherwise = Generalized s e  -- | Record field assignment @f = e@.@@ -126,46 +131,43 @@ type RecordAssign  = Either Assign ModuleName type RecordAssigns = [RecordAssign] --- | Is a type signature a `postulate' or a function signature?-data Axiom-  = FunSig    -- ^ A function signature.-  | NoFunSig  -- ^ Not a function signature, i.e., a postulate (in user input)-              --   or another (e.g. data/record) type signature (internally).-  deriving (Data, Eq, Ord, Show)- -- | Renaming (generic).-type Ren a = [(a, a)]+type Ren a = Map a (List1 a)  data ScopeCopyInfo = ScopeCopyInfo   { renModules :: Ren ModuleName   , renNames   :: Ren QName }-  deriving (Eq, Show, Data)+  deriving (Eq, Show, Data, Generic)  initCopyInfo :: ScopeCopyInfo initCopyInfo = ScopeCopyInfo-  { renModules = []-  , renNames   = []+  { renModules = mempty+  , renNames   = mempty   }  instance Pretty ScopeCopyInfo where   pretty i = vcat [ prRen "renModules =" (renModules i)                   , prRen "renNames   =" (renNames i) ]     where-      prRen s r = sep [ text s, nest 2 $ vcat (map pr r) ]+      prRen s r = sep [ text s, nest 2 $ vcat (map pr xs) ]+        where+          xs = [ (k, v) | (k, vs) <- Map.toList r, v <- List1.toList vs ]       pr (x, y) = pretty x <+> "->" <+> pretty y +type RecordDirectives = RecordDirectives' QName+ data Declaration-  = Axiom      Axiom DefInfo ArgInfo (Maybe [Occurrence]) QName Expr+  = Axiom      KindOfName DefInfo ArgInfo (Maybe [Occurrence]) QName Expr     -- ^ Type signature (can be irrelevant, but not hidden).     --     -- The fourth argument contains an optional assignment of     -- polarities to arguments.-  | Generalize (Set.Set QName) DefInfo ArgInfo QName Expr+  | Generalize (Set QName) DefInfo ArgInfo QName Expr     -- ^ First argument is set of generalizable variables used in the type.   | Field      DefInfo QName (Arg Expr)              -- ^ record field-  | Primitive  DefInfo QName Expr                    -- ^ primitive function+  | Primitive  DefInfo QName (Arg Expr)              -- ^ primitive function   | Mutual     MutualInfo [Declaration]              -- ^ a bunch of mutually recursive definitions-  | Section    ModuleInfo ModuleName GeneralizeTelescope [Declaration]+  | Section    Range ModuleName GeneralizeTelescope [Declaration]   | Apply      ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective     -- ^ The @ImportDirective@ is for highlighting purposes.   | Import     ModuleInfo ModuleName ImportDirective@@ -176,18 +178,17 @@   | FunDef     DefInfo QName Delayed [Clause] -- ^ sequence of function clauses   | DataSig    DefInfo QName GeneralizeTelescope Expr -- ^ lone data signature   | DataDef    DefInfo QName UniverseCheck DataDefParams [Constructor]-      -- ^ the 'LamBinding's are 'DomainFree' and bind the parameters of the datatype.   | RecSig     DefInfo QName GeneralizeTelescope Expr -- ^ lone record signature-  | RecDef     DefInfo QName UniverseCheck (Maybe (Ranged Induction)) (Maybe HasEta) (Maybe QName) DataDefParams Expr [Declaration]-      -- ^ The 'LamBinding's are 'DomainFree' and bind the parameters of the datatype.-      --   The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,+  | RecDef     DefInfo QName UniverseCheck RecordDirectives DataDefParams Expr [Declaration]+      -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,       --   and the optional name is the constructor's name.-  | PatternSynDef QName [Arg Name] (Pattern' Void)+      --   The optional 'Range' is for the @pattern@ attribute.+  | PatternSynDef QName [Arg BindName] (Pattern' Void)       -- ^ Only for highlighting purposes   | UnquoteDecl MutualInfo [DefInfo] [QName] Expr   | UnquoteDef  [DefInfo] [QName] Expr   | ScopedDecl ScopeInfo [Declaration]  -- ^ scope annotation-  deriving (Data, Show)+  deriving (Data, Show, Generic)  type DefInfo = DefInfo' Expr @@ -200,14 +201,14 @@       -- ^ @tel. M args@:  applies @M@ to @args@ and abstracts @tel@.     | RecordModuleInstance ModuleName       -- ^ @M {{...}}@-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  data Pragma   = OptionsPragma [String]   | BuiltinPragma RString ResolvedName     -- ^ 'ResolvedName' is not 'UnknownName'.     --   Name can be ambiguous e.g. for built-in constructors.-  | BuiltinNoDefPragma RString QName+  | BuiltinNoDefPragma RString KindOfName QName     -- ^ Builtins that do not come with a definition,     --   but declare a name for an Agda concept.   | RewritePragma Range [QName]@@ -220,7 +221,7 @@   | InjectivePragma QName   | InlinePragma Bool QName -- INLINE or NOINLINE   | DisplayPragma QName [NamedArg Pattern] Expr-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  -- | Bindings that are valid in a @let@. data LetBinding@@ -237,8 +238,7 @@     -- ^ Only used for highlighting. Refers to the first occurrence of     -- @x@ in @let x : A; x = e@. --  | LetGeneralize DefInfo ArgInfo Expr-  deriving (Data, Show, Eq)-+  deriving (Data, Show, Eq, Generic)  -- | Only 'Axiom's. type TypeSignature  = Declaration@@ -251,7 +251,7 @@ data Binder' a = Binder   { binderPattern :: Maybe Pattern   , binderName    :: a-  } deriving (Data, Show, Eq, Functor, Foldable, Traversable)+  } deriving (Data, Show, Eq, Functor, Foldable, Traversable, Generic)  type Binder = Binder' BindName @@ -270,7 +270,7 @@     -- ^ . @x@ or @{x}@ or @.x@ or @{x = y}@ or @x\@p@ or @(p)@   | DomainFull TypedBinding     -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  mkDomainFree :: NamedArg Binder -> LamBinding mkDomainFree = DomainFree Nothing@@ -290,23 +290,32 @@ --   that the metas of the copy are aliases of the metas of the original.  data TypedBinding-  = TBind Range TacticAttr [NamedArg Binder] Expr+  = TBind Range TacticAttr (List1 (NamedArg Binder)) Expr     -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@.-  | TLet Range [LetBinding]+  | TLet Range (List1 LetBinding)     -- ^ E.g. @(let x = e)@ or @(let open M)@.-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic) -mkTBind :: Range -> [NamedArg Binder] -> Expr -> TypedBinding+mkTBind :: Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding mkTBind r = TBind r Nothing +mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding+mkTLet _ []     = Nothing+mkTLet r (d:ds) = Just $ TLet r (d :| ds)++type Telescope1 = List1 TypedBinding type Telescope  = [TypedBinding] +mkPi :: ExprInfo -> Telescope -> Expr -> Expr+mkPi i []     e = e+mkPi i (x:xs) e = Pi i (x :| xs) e+ data GeneralizeTelescope = GeneralizeTel   { generalizeTelVars :: Map QName Name     -- ^ Maps generalize variables to the corresponding bound variable (to be     --   introduced by the generalisation).   , generalizeTel     :: Telescope }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  data DataDefParams = DataDefParams   { dataDefGeneralizedParams :: Set Name@@ -314,7 +323,7 @@     --   sig, so we keep these in a set on the side.   , dataDefParams :: [LamBinding]   }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  noDataDefParams :: DataDefParams noDataDefParams = DataDefParams Set.empty []@@ -330,11 +339,13 @@ --      been bound. --    * User pattern is an absurd pattern: --      emptiness of the type will be checked after splitting is complete.+--    * User pattern is an annotated wildcard:+--      type annotation will be checked after splitting is complete. data ProblemEq = ProblemEq   { problemInPat :: Pattern   , problemInst  :: I.Term   , problemType  :: I.Dom I.Type-  } deriving (Data, Show)+  } deriving (Data, Show, Generic)  -- These are not relevant for caching purposes instance Eq ProblemEq where _ == _ = True@@ -350,19 +361,27 @@   , clauseRHS        :: RHS   , clauseWhereDecls :: WhereDeclarations   , clauseCatchall   :: Bool-  } deriving (Data, Show, Functor, Foldable, Traversable, Eq)+  } deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)  data WhereDeclarations = WhereDecls   { whereModule :: Maybe ModuleName-  , whereDecls  :: [Declaration]-  } deriving (Data, Show, Eq)+      -- #2897: we need to restrict named where modules in refined contexts,+      --        so remember whether it was named here+  , whereDecls  :: Maybe Declaration+      -- ^ The declaration is a 'Section'.+  } deriving (Data, Show, Eq, Generic) +instance Null WhereDeclarations where+  empty = WhereDecls empty empty+ noWhereDecls :: WhereDeclarations-noWhereDecls = WhereDecls Nothing []+noWhereDecls = empty  type Clause = Clause' LHS type SpineClause = Clause' SpineLHS-type RewriteEqn  = RewriteEqn' QName Pattern Expr+type RewriteEqn  = RewriteEqn' QName BindName Pattern Expr+type WithExpr' e = Named BindName (Arg e)+type WithExpr    = WithExpr' Expr  data RHS   = RHS@@ -373,7 +392,7 @@       --   'Nothing' for internally generated rhss.     }   | AbsurdRHS-  | WithRHS QName [WithHiding Expr] [Clause]+  | WithRHS QName [WithExpr] [Clause]       -- ^ The 'QName' is the name of the with function.   | RewriteRHS     { rewriteExprs      :: [RewriteEqn]@@ -388,13 +407,13 @@       -- ^ The where clauses are attached to the @RewriteRHS@ by       ---  the scope checker (instead of to the clause).     }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  -- | Ignore 'rhsConcrete' when comparing 'RHS's. instance Eq RHS where   RHS e _          == RHS e' _            = e == e'   AbsurdRHS        == AbsurdRHS           = True-  WithRHS a b c    == WithRHS a' b' c'    = and [ a == a', b == b', c == c' ]+  WithRHS a b c    == WithRHS a' b' c'    = (a == a') && (b == b') && (c == c')   RewriteRHS a b c d == RewriteRHS a' b' c' d' = and [ a == a', b == b', c == c' , d == d' ]   _                == _                   = False @@ -406,7 +425,7 @@   , spLhsDefName  :: QName               -- ^ Name of function we are defining.   , spLhsPats     :: [NamedArg Pattern]  -- ^ Elimination by pattern, projections, with-patterns.   }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  -- | Ignore 'Range' when comparing 'LHS's. instance Eq LHS where@@ -418,7 +437,7 @@   { lhsInfo     :: LHSInfo               -- ^ Range.   , lhsCore     :: LHSCore               -- ^ Copatterns.   }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  -- | The lhs in projection-application and with-pattern view. --   Parameterised over the type @e@ of dot patterns.@@ -440,13 +459,13 @@     -- | With patterns.   | LHSWith  { lhsHead         :: LHSCore' e                  -- ^ E.g. the 'LHSHead'.-             , lhsWithPatterns :: [Pattern' e]+             , lhsWithPatterns :: [Arg (Pattern' e)]                  -- ^ Applied to with patterns @| p1 | ... | pn@.                  --   These patterns are not prefixed with @WithP@!              , lhsPats         :: [NamedArg (Pattern' e)]                  -- ^ Further applied to patterns.              }-  deriving (Data, Show, Functor, Foldable, Traversable, Eq)+  deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)  type LHSCore = LHSCore' Expr @@ -471,14 +490,16 @@   | DotP PatInfo e     -- ^ Dot pattern @.e@   | AbsurdP PatInfo-  | LitP Literal+  | LitP PatInfo Literal   | PatternSynP PatInfo AmbiguousQName (NAPs e)   | RecP PatInfo [FieldAssignment' (Pattern' e)]   | EqualP PatInfo [(e, e)]   | WithP PatInfo (Pattern' e)  -- ^ @| p@, for with-patterns.-  deriving (Data, Show, Functor, Foldable, Traversable, Eq)+  | AnnP PatInfo e (Pattern' e) -- ^ Pattern with type annotation+  deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)  type NAPs e   = [NamedArg (Pattern' e)]+type NAPs1 e  = List1 (NamedArg (Pattern' e)) type Pattern  = Pattern' Expr type Patterns = [NamedArg Pattern] @@ -498,7 +519,7 @@     Things we parse but are not part of the Agda file syntax  --------------------------------------------------------------------------} -type HoleContent = C.HoleContent' () Pattern Expr+type HoleContent = C.HoleContent' () BindName Pattern Expr  {--------------------------------------------------------------------------     Instances@@ -508,39 +529,38 @@ --   Does not distinguish between prefix and postfix projections.  instance Eq Expr where-  ScopedExpr _ a1         == ScopedExpr _ a2         = a1 == a2+  ScopedExpr _ a1            == ScopedExpr _ a2            = a1 == a2 -  Var a1                  == Var a2                  = a1 == a2-  Def a1                  == Def a2                  = a1 == a2-  Proj _ a1               == Proj _ a2               = a1 == a2-  Con a1                  == Con a2                  = a1 == a2-  PatternSyn a1           == PatternSyn a2           = a1 == a2-  Macro a1                == Macro a2                = a1 == a2-  Lit a1                  == Lit a2                  = a1 == a2-  QuestionMark a1 b1      == QuestionMark a2 b2      = (a1, b1) == (a2, b2)-  Underscore a1           == Underscore a2           = a1 == a2-  Dot r1 e1               == Dot r2 e2               = (r1, e1) == (r2, e2)-  App a1 b1 c1            == App a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  WithApp a1 b1 c1        == WithApp a2 b2 c2        = (a1, b1, c1) == (a2, b2, c2)-  Lam a1 b1 c1            == Lam a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  AbsurdLam a1 b1         == AbsurdLam a2 b2         = (a1, b1) == (a2, b2)-  ExtendedLam a1 b1 c1 d1 == ExtendedLam a2 b2 c2 d2 = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  Pi a1 b1 c1             == Pi a2 b2 c2             = (a1, b1, c1) == (a2, b2, c2)-  Generalized a1 b1       == Generalized a2 b2       = (a1, b1) == (a2, b2)-  Fun a1 b1 c1            == Fun a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  Set a1 b1               == Set a2 b2               = (a1, b1) == (a2, b2)-  Prop a1 b1              == Prop a2 b2              = (a1, b1) == (a2, b2)-  Let a1 b1 c1            == Let a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  ETel a1                 == ETel a2                 = a1 == a2-  Rec a1 b1               == Rec a2 b2               = (a1, b1) == (a2, b2)-  RecUpdate a1 b1 c1      == RecUpdate a2 b2 c2      = (a1, b1, c1) == (a2, b2, c2)-  Quote a1                == Quote a2                = a1 == a2-  QuoteTerm a1            == QuoteTerm a2            = a1 == a2-  Unquote a1              == Unquote a2              = a1 == a2-  Tactic a1 b1 c1         == Tactic a2 b2 c2         = (a1, b1, c1) == (a2, b2, c2)-  DontCare a1             == DontCare a2             = a1 == a2+  Var a1                     == Var a2                     = a1 == a2+  Def' a1 s1                 == Def' a2 s2                 = (a1, s1) == (a2, s2)+  Proj _ a1                  == Proj _ a2                  = a1 == a2+  Con a1                     == Con a2                     = a1 == a2+  PatternSyn a1              == PatternSyn a2              = a1 == a2+  Macro a1                   == Macro a2                   = a1 == a2+  Lit r1 a1                  == Lit r2 a2                  = (r1, a1) == (r2, a2)+  QuestionMark a1 b1         == QuestionMark a2 b2         = (a1, b1) == (a2, b2)+  Underscore a1              == Underscore a2              = a1 == a2+  Dot r1 e1                  == Dot r2 e2                  = (r1, e1) == (r2, e2)+  App a1 b1 c1               == App a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)+  WithApp a1 b1 c1           == WithApp a2 b2 c2           = (a1, b1, c1) == (a2, b2, c2)+  Lam a1 b1 c1               == Lam a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)+  AbsurdLam a1 b1            == AbsurdLam a2 b2            = (a1, b1) == (a2, b2)+  ExtendedLam a1 b1 c1 d1 e1 == ExtendedLam a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) ==+                                                             (a2, b2, c2, d2, e2)+  Pi a1 b1 c1                == Pi a2 b2 c2                = (a1, b1, c1) == (a2, b2, c2)+  Generalized a1 b1          == Generalized a2 b2          = (a1, b1) == (a2, b2)+  Fun a1 b1 c1               == Fun a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)+  Let a1 b1 c1               == Let a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)+  ETel a1                    == ETel a2                    = a1 == a2+  Rec a1 b1                  == Rec a2 b2                  = (a1, b1) == (a2, b2)+  RecUpdate a1 b1 c1         == RecUpdate a2 b2 c2         = (a1, b1, c1) == (a2, b2, c2)+  Quote a1                   == Quote a2                   = a1 == a2+  QuoteTerm a1               == QuoteTerm a2               = a1 == a2+  Unquote a1                 == Unquote a2                 = a1 == a2+  Tactic a1 b1 c1            == Tactic a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)+  DontCare a1                == DontCare a2                = a1 == a2 -  _                       == _                       = False+  _                          == _                          = False  -- | Does not compare 'ScopeInfo' fields. @@ -561,7 +581,7 @@   DataSig a1 b1 c1 d1            == DataSig a2 b2 c2 d2            = (a1, b1, c1, d1) == (a2, b2, c2, d2)   DataDef a1 b1 c1 d1 e1         == DataDef a2 b2 c2 d2 e2         = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)   RecSig a1 b1 c1 d1             == RecSig a2 b2 c2 d2             = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  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)+  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)   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)@@ -579,10 +599,9 @@   mapHiding f (DomainFull tb)  = DomainFull $ mapHiding f tb  instance LensHiding TypedBinding where-  getHiding (TBind _ _ (x : _) _) = getHiding x   -- Slightly dubious-  getHiding (TBind _ _ [] _)      = __IMPOSSIBLE__+  getHiding (TBind _ _ (x :|_) _) = getHiding x   -- Slightly dubious   getHiding TLet{}                = mempty-  mapHiding f (TBind r t xs e)    = TBind r t ((map . mapHiding) f xs) e+  mapHiding f (TBind r t xs e)    = TBind r t ((fmap . mapHiding) f xs) e   mapHiding f b@TLet{}            = b  instance HasRange a => HasRange (Binder' a) where@@ -597,36 +616,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 l)               = getRange l-    getRange (QuestionMark i _)    = getRange i-    getRange (Underscore  i)       = getRange i-    getRange (Dot i _)             = getRange i-    getRange (App i _ _)           = getRange i-    getRange (WithApp i _ _)       = getRange i-    getRange (Lam i _ _)           = getRange i-    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 (Set i _)             = getRange i-    getRange (Prop i _)            = getRange i-    getRange (Let i _ _)           = getRange i-    getRange (Rec i _)             = getRange i-    getRange (RecUpdate i _ _)     = getRange i-    getRange (ETel tel)            = getRange tel-    getRange (ScopedExpr _ e)      = getRange e-    getRange (Quote i)             = getRange i-    getRange (QuoteTerm i)         = getRange i-    getRange (Unquote i)           = getRange i-    getRange (Tactic 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 (ETel tel)              = getRange tel+    getRange (ScopedExpr _ e)        = getRange e+    getRange (Quote i)               = getRange i+    getRange (QuoteTerm i)           = getRange i+    getRange (Unquote i)             = getRange i+    getRange (Tactic i _ _)          = getRange i+    getRange (DontCare{})            = noRange+    getRange (PatternSyn x)          = getRange x+    getRange (Macro x)               = getRange x  instance HasRange Declaration where     getRange (Axiom    _ i _ _ _ _  ) = getRange i@@ -644,7 +661,7 @@     getRange (DataSig    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@@ -658,11 +675,12 @@     getRange (AsP i _ _)         = getRange i     getRange (DotP i _)          = getRange i     getRange (AbsurdP i)         = getRange i-    getRange (LitP l)            = getRange l+    getRange (LitP i l)          = getRange i     getRange (PatternSynP i _ _) = getRange i     getRange (RecP i _)          = getRange i     getRange (EqualP i _)        = getRange i     getRange (WithP i _)         = getRange i+    getRange (AnnP i _ _)        = getRange i  instance HasRange SpineLHS where     getRange (SpineLHS i _ _)  = getRange i@@ -704,11 +722,12 @@     setRange r (AsP _ n p)          = AsP (PatRange r) (setRange r n) p     setRange r (DotP _ e)           = DotP (PatRange r) e     setRange r (AbsurdP _)          = AbsurdP (PatRange r)-    setRange r (LitP l)             = LitP (setRange r l)+    setRange r (LitP _ l)           = LitP (PatRange r) l     setRange r (PatternSynP _ n as) = PatternSynP (PatRange r) n as     setRange r (RecP i as)          = RecP (PatRange r) as     setRange r (EqualP _ es)        = EqualP (PatRange r) es     setRange r (WithP i p)          = WithP (setRange r i) p+    setRange r (AnnP i a p)         = AnnP (setRange r i) a p  instance KillRange a => KillRange (Binder' a) where   killRange (Binder a b) = killRange2 Binder a b@@ -728,37 +747,38 @@   killRange (TLet r lbs)     = killRange2 TLet r lbs  instance KillRange Expr where-  killRange (Var x)                = killRange1 Var x-  killRange (Def x)                = killRange1 Def x-  killRange (Proj o x)             = killRange1 (Proj o) x-  killRange (Con x)                = killRange1 Con x-  killRange (Lit l)                = killRange1 Lit l-  killRange (QuestionMark i ii)    = killRange2 QuestionMark i ii-  killRange (Underscore  i)        = killRange1 Underscore i-  killRange (Dot i e)              = killRange2 Dot i e-  killRange (App i e1 e2)          = killRange3 App i e1 e2-  killRange (WithApp i e es)       = killRange3 WithApp i e es-  killRange (Lam i b e)            = killRange3 Lam i b e-  killRange (AbsurdLam i h)        = killRange2 AbsurdLam i h-  killRange (ExtendedLam i n d ps) = killRange4 ExtendedLam i n d ps-  killRange (Pi i a b)             = killRange3 Pi i a b-  killRange (Generalized s x)      = killRange1 (Generalized s) x-  killRange (Fun i a b)            = killRange3 Fun i a b-  killRange (Set i n)              = killRange2 Set i n-  killRange (Prop i n)             = killRange2 Prop i n-  killRange (Let i ds e)           = killRange3 Let i ds e-  killRange (Rec i fs)             = killRange2 Rec i fs-  killRange (RecUpdate i e fs)     = killRange3 RecUpdate i e fs-  killRange (ETel tel)             = killRange1 ETel tel-  killRange (ScopedExpr s e)       = killRange1 (ScopedExpr s) e-  killRange (Quote i)              = killRange1 Quote i-  killRange (QuoteTerm i)          = killRange1 QuoteTerm i-  killRange (Unquote i)            = killRange1 Unquote i-  killRange (Tactic i e xs)        = killRange3 Tactic i e xs-  killRange (DontCare e)           = killRange1 DontCare e-  killRange (PatternSyn x)         = killRange1 PatternSyn x-  killRange (Macro x)              = killRange1 Macro x+  killRange (Var x)                  = killRange1 Var x+  killRange (Def' x v)               = killRange2 Def' x v+  killRange (Proj o x)               = killRange1 (Proj o) x+  killRange (Con x)                  = killRange1 Con x+  killRange (Lit i l)                = killRange2 Lit i l+  killRange (QuestionMark i ii)      = killRange2 QuestionMark i ii+  killRange (Underscore  i)          = killRange1 Underscore i+  killRange (Dot i e)                = killRange2 Dot i e+  killRange (App i e1 e2)            = killRange3 App i e1 e2+  killRange (WithApp i e es)         = killRange3 WithApp i e es+  killRange (Lam i b e)              = killRange3 Lam i b e+  killRange (AbsurdLam i h)          = killRange2 AbsurdLam i h+  killRange (ExtendedLam i n e d ps) = killRange5 ExtendedLam i n e d ps+  killRange (Pi i a b)               = killRange3 Pi i a b+  killRange (Generalized s x)        = killRange1 (Generalized s) x+  killRange (Fun i a b)              = killRange3 Fun i a b+  killRange (Let i ds e)             = killRange3 Let i ds e+  killRange (Rec i fs)               = killRange2 Rec i fs+  killRange (RecUpdate i e fs)       = killRange3 RecUpdate i e fs+  killRange (ETel tel)               = killRange1 ETel tel+  killRange (ScopedExpr s e)         = killRange1 (ScopedExpr s) e+  killRange (Quote i)                = killRange1 Quote i+  killRange (QuoteTerm i)            = killRange1 QuoteTerm i+  killRange (Unquote i)              = killRange1 Unquote i+  killRange (Tactic i e xs)          = killRange3 Tactic i e xs+  killRange (DontCare e)             = killRange1 DontCare e+  killRange (PatternSyn x)           = killRange1 PatternSyn x+  killRange (Macro x)                = killRange1 Macro x +instance KillRange Suffix where+  killRange = id+ instance KillRange Declaration where   killRange (Axiom    p i a b c d     ) = killRange4 (\i a c d -> Axiom p i a b c d) i a c d   killRange (Generalize s i j x e     ) = killRange4 (Generalize s) i j x e@@ -775,7 +795,7 @@   killRange (DataSig i a b c          ) = killRange4 DataSig i a b c   killRange (DataDef i a b c d        ) = killRange5 DataDef i a b c d   killRange (RecSig  i a b c          ) = killRange4 RecSig  i a b c-  killRange (RecDef  i a b c d e f g h) = killRange9 RecDef  i a b c d e f g h+  killRange (RecDef  i a b c d e f    ) = killRange7 RecDef  i a b c d e f   killRange (PatternSynDef x xs p     ) = killRange3 PatternSynDef x xs p   killRange (UnquoteDecl mi i x e     ) = killRange4 UnquoteDecl mi i x e   killRange (UnquoteDef i x e         ) = killRange3 UnquoteDef i x e@@ -796,11 +816,12 @@   killRange (AsP i a b)         = killRange3 AsP i a b   killRange (DotP i a)          = killRange2 DotP i a   killRange (AbsurdP i)         = killRange1 AbsurdP i-  killRange (LitP l)            = killRange1 LitP l+  killRange (LitP i l)          = killRange2 LitP i l   killRange (PatternSynP i a p) = killRange3 PatternSynP i a p   killRange (RecP i as)         = killRange2 RecP i as   killRange (EqualP i es)       = killRange2 EqualP i es   killRange (WithP i p)         = killRange2 WithP i p+  killRange (AnnP i a p)        = killRange3 AnnP i a p  instance KillRange SpineLHS where   killRange (SpineLHS i a b)  = killRange3 SpineLHS i a b@@ -835,147 +856,31 @@   killRange (LetOpen    i x dir     ) = killRange3 LetOpen  i x dir   killRange (LetDeclaredVariable x)  = killRange1 LetDeclaredVariable x --- See Agda.Utils.GeniPlate:--- Does not descend into ScopeInfo and renaming maps, for instance.--instanceUniverseBiT' [] [t| (Declaration, QName)          |]-instanceUniverseBiT' [] [t| (Declaration, AmbiguousQName) |]-instanceUniverseBiT' [] [t| (Declaration, Expr)           |]-instanceUniverseBiT' [] [t| (Declaration, LetBinding)     |]-instanceUniverseBiT' [] [t| (Declaration, LamBinding)     |]-instanceUniverseBiT' [] [t| (Declaration, TypedBinding)   |]-instanceUniverseBiT' [] [t| (Declaration, Pattern)        |]-instanceUniverseBiT' [] [t| (Declaration, Pattern' Void)  |]-instanceUniverseBiT' [] [t| (Declaration, Declaration)    |]-instanceUniverseBiT' [] [t| (Declaration, ModuleName)     |]-instanceUniverseBiT' [] [t| (Declaration, ModuleInfo)     |]-instanceUniverseBiT' [] [t| (Declaration, NamedArg LHSCore)  |]-instanceUniverseBiT' [] [t| (Declaration, NamedArg BindName) |]-instanceUniverseBiT' [] [t| (Declaration, NamedArg Expr)     |]-instanceUniverseBiT' [] [t| (Declaration, NamedArg Pattern)  |]-instanceUniverseBiT' [] [t| (Declaration, Quantity)          |]+instance NFData Expr+instance NFData ScopeCopyInfo+instance NFData Declaration+instance NFData ModuleApplication+instance NFData Pragma+instance NFData LetBinding+instance NFData a => NFData (Binder' a)+instance NFData LamBinding+instance NFData TypedBinding+instance NFData GeneralizeTelescope+instance NFData DataDefParams+instance NFData ProblemEq+instance NFData lhs => NFData (Clause' lhs)+instance NFData WhereDeclarations+instance NFData RHS+instance NFData SpineLHS+instance NFData LHS+instance NFData e => NFData (LHSCore' e)+instance NFData e => NFData (Pattern' e)  ------------------------------------------------------------------------ -- Queries ------------------------------------------------------------------------ --- | Extracts all the names which are declared in a 'Declaration'.--- This does not include open public or let expressions, but it does--- include local modules, where clauses and the names of extended--- lambdas.--class AllNames a where-  allNames :: a -> Seq QName--instance AllNames a => AllNames [a] where-  allNames = Fold.foldMap allNames--instance AllNames a => AllNames (Maybe a) where-  allNames = Fold.foldMap allNames--instance AllNames a => AllNames (Arg a) where-  allNames = Fold.foldMap allNames--instance AllNames a => AllNames (Named name a) where-  allNames = Fold.foldMap allNames--instance (AllNames a, AllNames b) => AllNames (a,b) where-  allNames (a,b) = allNames a >< allNames b--instance (AllNames a, AllNames b, AllNames c) => AllNames (a,b,c) where-  allNames (a,b,c) = allNames a >< allNames b >< allNames c--instance AllNames QName where-  allNames q = Seq.singleton q--instance AllNames Declaration where-  allNames (Axiom   _ _ _ _ q _)      = Seq.singleton q-  allNames (Generalize _ _ _ q _)     = Seq.singleton q-  allNames (Field     _   q _)        = Seq.singleton q-  allNames (Primitive _   q _)        = Seq.singleton q-  allNames (Mutual     _ defs)        = allNames defs-  allNames (DataSig _ q _ _)          = Seq.singleton q-  allNames (DataDef _ q _ _ decls)    = q <| allNames decls-  allNames (RecSig _ q _ _)           = Seq.singleton q-  allNames (RecDef _ q _ _ _ c _ _ decls) = q <| allNames c >< allNames decls-  allNames (PatternSynDef q _ _)      = Seq.singleton q-  allNames (UnquoteDecl _ _ qs _)     = Seq.fromList qs-  allNames (UnquoteDef _ qs _)        = Seq.fromList qs-  allNames (FunDef _ q _ cls)         = q <| allNames cls-  allNames (Section _ _ _ decls)      = allNames decls-  allNames Apply{}                    = Seq.empty-  allNames Import{}                   = Seq.empty-  allNames Pragma{}                   = Seq.empty-  allNames Open{}                     = Seq.empty-  allNames (ScopedDecl _ decls)       = allNames decls--instance AllNames Clause where-  allNames cl = allNames (clauseRHS cl, clauseWhereDecls cl)--instance (AllNames qn, AllNames e) => AllNames (RewriteEqn' qn p e) where-    allNames = \case-      Rewrite es    -> Fold.foldMap allNames es-      Invert qn pes -> allNames qn >< foldMap (Fold.foldMap allNames) pes--instance AllNames RHS where-  allNames (RHS e _)                 = allNames e-  allNames AbsurdRHS{}               = Seq.empty-  allNames (WithRHS q _ cls)         = q <| allNames cls-  allNames (RewriteRHS qes _ rhs cls) = allNames (qes, rhs, cls)--instance AllNames WhereDeclarations where-  allNames (WhereDecls _ ds) = allNames ds--instance AllNames Expr where-  allNames Var{}                   = Seq.empty-  allNames Def{}                   = Seq.empty-  allNames Proj{}                  = Seq.empty-  allNames Con{}                   = Seq.empty-  allNames Lit{}                   = Seq.empty-  allNames QuestionMark{}          = Seq.empty-  allNames Underscore{}            = Seq.empty-  allNames (Dot _ e)               = allNames e-  allNames (App _ e1 e2)           = allNames e1 >< allNames e2-  allNames (WithApp _ e es)        = allNames e >< allNames es-  allNames (Lam _ b e)             = allNames b >< allNames e-  allNames AbsurdLam{}             = Seq.empty-  allNames (ExtendedLam _ _ q cls) = q <| allNames cls-  allNames (Pi _ tel e)            = allNames tel >< allNames e-  allNames (Generalized s e)       = Seq.fromList (Set.toList s) >< allNames e  -- TODO: or just (allNames e)?-  allNames (Fun _ e1 e2)           = allNames e1 >< allNames e2-  allNames Set{}                   = Seq.empty-  allNames Prop{}                  = Seq.empty-  allNames (Let _ lbs e)           = allNames lbs >< allNames e-  allNames ETel{}                  = __IMPOSSIBLE__-  allNames (Rec _ fields)          = allNames [ a ^. exprFieldA | Left a <- fields ]-  allNames (RecUpdate _ e fs)      = allNames e >< allNames (map (view exprFieldA) fs)-  allNames (ScopedExpr _ e)        = allNames e-  allNames Quote{}                 = Seq.empty-  allNames QuoteTerm{}             = Seq.empty-  allNames Unquote{}               = Seq.empty-  allNames (Tactic _ e xs)         = allNames e >< allNames xs-  allNames DontCare{}              = Seq.empty-  allNames PatternSyn{}            = Seq.empty-  allNames Macro{}                 = Seq.empty--instance AllNames LamBinding where-  allNames DomainFree{}       = Seq.empty-  allNames (DomainFull binds) = allNames binds--instance AllNames TypedBinding where-  allNames (TBind _ t _ e) = allNames (t, e)-  allNames (TLet _ lbs)  = allNames lbs--instance AllNames LetBinding where-  allNames (LetBind _ _ _ e1 e2)  = allNames e1 >< allNames e2-  allNames (LetPatBind _ _ e)      = allNames e-  allNames (LetApply _ _ app _ _)  = allNames app-  allNames LetOpen{}               = Seq.empty-  allNames (LetDeclaredVariable _) = Seq.empty--instance AllNames ModuleApplication where-  allNames (SectionApp bindss _ es) = allNames bindss >< allNames es-  allNames RecordModuleInstance{}   = Seq.empty+-- class AllNames moved to Abstract.Views.DeclaredNames  -- | The name defined by the given axiom. --@@ -1003,7 +908,7 @@   anyAbstract (Section _ _ _ ds)     = anyAbstract ds   anyAbstract (FunDef i _ _ _)       = defAbstract i == AbstractDef   anyAbstract (DataDef i _ _ _ _)    = defAbstract i == AbstractDef-  anyAbstract (RecDef i _ _ _ _ _ _ _ _) = defAbstract i == AbstractDef+  anyAbstract (RecDef i _ _ _ _ _ _) = defAbstract i == AbstractDef   anyAbstract (DataSig i _ _ _)      = defAbstract i == AbstractDef   anyAbstract (RecSig i _ _ _)       = defAbstract i == AbstractDef   anyAbstract _                      = __IMPOSSIBLE__@@ -1028,6 +933,7 @@       DisallowedGeneralizeName -> Def x       FldName                  -> Proj ProjSystem ux       ConName                  -> Con ux+      CoConName                -> Con ux       PatternSynName           -> PatternSyn ux       MacroName                -> Macro x       QuotableName             -> App (defaultAppInfo r) (Quote i) (defaultNamedArg $ Def x)@@ -1044,18 +950,22 @@ instance NameToExpr ResolvedName where   nameToExpr = \case     VarName x _          -> Var x-    DefinedName _ x      -> nameToExpr x  -- Can be 'isDefName', 'MacroName', 'QuotableName'.+    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+    ConstructorName _ xs -> Con . AmbQ . fmap anameName $ xs     PatternSynResName xs -> PatternSyn . AmbQ . fmap anameName $ xs     UnknownName          -> __IMPOSSIBLE__+    where+      withSuffix NoSuffix   e       = e+      withSuffix s@Suffix{} (Def x) = Def' x s+      withSuffix _          _       = __IMPOSSIBLE__  app :: Expr -> [NamedArg Expr] -> Expr app = foldl (App defaultAppInfo_)  mkLet :: ExprInfo -> [LetBinding] -> Expr -> Expr-mkLet i [] e = e-mkLet i ds e = Let i ds e+mkLet _ []     e = e+mkLet i (d:ds) e = Let i (d :| ds) e  patternToExpr :: Pattern -> Expr patternToExpr = \case@@ -1067,35 +977,39 @@   AsP _ _ p          -> patternToExpr p   DotP _ e           -> e   AbsurdP _          -> Underscore emptyMetaInfo  -- TODO: could this happen?-  LitP l             -> Lit l+  LitP (PatRange r) l-> Lit (ExprRange r) l   PatternSynP _ c ps -> PatternSyn c `app` (map . fmap . fmap) patternToExpr ps   RecP _ as          -> Rec exprNoRange $ map (Left . fmap patternToExpr) as   EqualP{}           -> __IMPOSSIBLE__  -- Andrea TODO: where is this used?   WithP r p          -> __IMPOSSIBLE__+  AnnP _ _ p         -> patternToExpr p  type PatternSynDefn = ([Arg Name], Pattern' Void) type PatternSynDefns = Map QName PatternSynDefn  lambdaLiftExpr :: [Name] -> Expr -> Expr-lambdaLiftExpr []     e = e-lambdaLiftExpr (n:ns) e =-  Lam exprNoRange (mkDomainFree $ defaultNamedArg $ mkBinder_ n) $-  lambdaLiftExpr ns e+lambdaLiftExpr ns e+  = foldr+      (\ n -> Lam exprNoRange (mkDomainFree $ defaultNamedArg $ mkBinder_ n))+      e+      ns +-- NOTE: This is only used on expressions that come from right-hand sides of pattern synonyms, and+-- thus does not have to handle all forms of expressions. class SubstExpr a where   substExpr :: [(Name, Expr)] -> a -> a -instance SubstExpr a => SubstExpr (Maybe a) where-  substExpr = fmap . substExpr--instance SubstExpr a => SubstExpr [a] where-  substExpr = fmap . substExpr--instance SubstExpr a => SubstExpr (Arg a) where+  default substExpr+    :: (Functor t, SubstExpr b, t b ~ a)+    => [(Name, Expr)] -> a -> a   substExpr = fmap . substExpr -instance SubstExpr a => SubstExpr (Named name a) where-  substExpr = fmap . substExpr+instance SubstExpr a => SubstExpr (Maybe a)+instance SubstExpr a => SubstExpr [a]+instance SubstExpr a => SubstExpr (List1 a)+instance SubstExpr a => SubstExpr (Arg a)+instance SubstExpr a => SubstExpr (Named name a)+instance SubstExpr a => SubstExpr (FieldAssignment' a)  instance (SubstExpr a, SubstExpr b) => SubstExpr (a, b) where   substExpr s (x, y) = (substExpr s x, substExpr s y)@@ -1110,53 +1024,37 @@ instance SubstExpr ModuleName where   substExpr _ = id -instance SubstExpr Assign where-  substExpr s (FieldAssignment n x) = FieldAssignment n (substExpr s x)- instance SubstExpr Expr where   substExpr s e = case e of-    Var n                 -> fromMaybe e (lookup n s)-    Def _                 -> e-    Proj{}                -> e-    Con _                 -> e-    Lit _                 -> e-    QuestionMark{}        -> e-    Underscore   _        -> e-    Dot i e               -> Dot i (substExpr s e)-    App  i e e'           -> App i (substExpr s e) (substExpr s e')-    WithApp i e es        -> WithApp i (substExpr s e) (substExpr s es)-    Lam  i lb e           -> Lam i lb (substExpr s e)-    AbsurdLam i h         -> e-    ExtendedLam i di n cs -> __IMPOSSIBLE__   -- Maybe later...-    Pi   i t e            -> Pi i (substExpr s t) (substExpr s e)-    Generalized ns e      -> Generalized ns (substExpr s e)-    Fun  i ae e           -> Fun i (substExpr s ae) (substExpr s e)-    Set  i n              -> e-    Prop i n              -> e-    Let  i ls e           -> Let i (substExpr s ls) (substExpr s e)-    ETel t                -> e-    Rec  i nes            -> Rec i (substExpr s nes)-    RecUpdate i e nes     -> RecUpdate i (substExpr s e) (substExpr s nes)-    -- XXX: Do we need to do more with ScopedExprs?-    ScopedExpr si e       -> ScopedExpr si (substExpr s e)-    Quote i               -> e-    QuoteTerm i           -> e-    Unquote i             -> e-    Tactic i e xs         -> Tactic i (substExpr s e) (substExpr s xs)-    DontCare e            -> DontCare (substExpr s e)-    PatternSyn{}          -> e-    Macro{}               -> e--instance SubstExpr LetBinding where-  substExpr s lb = case lb of-    LetBind i r n e e' -> LetBind i r n (substExpr s e) (substExpr s e')-    LetPatBind i p e   -> LetPatBind i p (substExpr s e) -- Andreas, 2012-06-04: what about the pattern p-    _                  -> lb -- Nicolas, 2013-11-11: what about "LetApply" there is experessions in there--instance SubstExpr TypedBinding where-  substExpr s tb = case tb of-    TBind r t ns e -> TBind r (substExpr s t) ns $ substExpr s e-    TLet r lbs     -> TLet r $ substExpr s lbs+    Var n           -> fromMaybe e (lookup n s)+    Con _           -> e+    Proj{}          -> e+    Def' _ _        -> e+    PatternSyn{}    -> e+    Lit _ _         -> e+    Underscore   _  -> e+    App  i e e'     -> App i (substExpr s e) (substExpr s e')+    Rec  i nes      -> Rec i (substExpr s nes)+    ScopedExpr si e -> ScopedExpr si (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__+    ETel{}          -> __IMPOSSIBLE__+    RecUpdate{}     -> __IMPOSSIBLE__+    Quote{}         -> __IMPOSSIBLE__+    QuoteTerm{}     -> __IMPOSSIBLE__+    Unquote{}       -> __IMPOSSIBLE__+    Tactic{}        -> __IMPOSSIBLE__+    DontCare{}      -> __IMPOSSIBLE__+    Macro{}         -> __IMPOSSIBLE__  -- TODO: more informative failure insertImplicitPatSynArgs

src/full/Agda/Syntax/Abstract/Name.hs view

@@ -1,33 +1,34 @@-{-# LANGUAGE DeriveDataTypeable         #-}  {-| Abstract names carry unique identifiers and stuff. -} module Agda.Syntax.Abstract.Name   ( module Agda.Syntax.Abstract.Name   , IsNoName(..)+  , FreshNameMode(..)   ) where +import Prelude hiding (length)+ import Control.DeepSeq  import Data.Data (Data)-import Data.Foldable (Foldable)+import Data.Foldable (length) import Data.Function import Data.Hashable (Hashable(..))-import Data.List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.List as List import Data.Maybe-import Data.Traversable (Traversable) import Data.Void  import Agda.Syntax.Position import Agda.Syntax.Common-import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..), NameInScope(..), LensInScope(..))+import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..), NameInScope(..), LensInScope(..), FreshNameMode(..)) import qualified Agda.Syntax.Concrete.Name as C  import Agda.Utils.Functor import Agda.Utils.Lens-import Agda.Utils.List+import qualified Agda.Utils.List as L+import Agda.Utils.List1 (List1, pattern (:|), (<|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Pretty import Agda.Utils.Size @@ -38,7 +39,8 @@ --   source location of the binding site is also recorded. data Name = Name   { nameId           :: !NameId-  , nameConcrete     :: C.Name+  , 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   , nameFixity       :: Fixity'   , nameIsRecordName :: Bool@@ -48,7 +50,7 @@  -- | Useful for debugging scoping problems uglyShowName :: Name -> String-uglyShowName (Name i c _ _ _) = show (i,c)+uglyShowName x = show (nameId x, nameConcrete x)  -- | 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@@ -79,8 +81,8 @@ -- -- Invariant: All the names in the list must have the same concrete, -- unqualified name.  (This implies that they all have the same 'Range').-newtype AmbiguousQName = AmbQ { unAmbQ :: NonEmpty QName }-  deriving (Eq, Ord, Data)+newtype AmbiguousQName = AmbQ { unAmbQ :: List1 QName }+  deriving (Eq, Ord, Data, NFData)  -- | A singleton "ambiguous" name. unambiguous :: QName -> AmbiguousQName@@ -88,7 +90,7 @@  -- | Get the first of the ambiguous names. headAmbQ :: AmbiguousQName -> QName-headAmbQ (AmbQ xs) = NonEmpty.head xs+headAmbQ (AmbQ xs) = List1.head xs  -- | Is a name ambiguous. isAmbiguous :: AmbiguousQName -> Bool@@ -99,6 +101,16 @@ getUnambiguous (AmbQ (x :| [])) = Just x getUnambiguous _                = Nothing +-- | A name suffix+data Suffix+  = NoSuffix+  | Suffix !Integer+  deriving (Data, Show, Eq, Ord)++instance NFData Suffix where+  rnf NoSuffix   = ()+  rnf (Suffix _) = ()+ -- | Check whether we are a projection pattern. class IsProjP a where   isProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)@@ -117,8 +129,7 @@  -- | A module is anonymous if the qualification path ends in an underscore. isAnonymousModuleName :: ModuleName -> Bool-isAnonymousModuleName (MName []) = False-isAnonymousModuleName (MName ms) = isNoName $ last ms+isAnonymousModuleName (MName mms) = maybe False isNoName $ L.lastMaybe mms  -- | Sets the ranges of the individual names in the module name to -- match those of the corresponding concrete names. If the concrete@@ -137,9 +148,9 @@ -- Precondition: The number of module name name parts has to be at -- least as large as the length of the list. -withRangesOf :: ModuleName -> [C.Name] -> ModuleName+withRangesOf :: ModuleName -> List1 C.Name -> ModuleName MName ms `withRangesOf` ns = if m < n then __IMPOSSIBLE__ else MName $-      zipWith setRange (replicate (m - n) noRange ++ map getRange ns) ms+      zipWith setRange (replicate (m - n) noRange ++ map getRange (List1.toList ns)) ms   where     m = length ms     n = length ns@@ -153,12 +164,18 @@ mnameFromList :: [Name] -> ModuleName mnameFromList = MName +mnameFromList1 :: List1 Name -> ModuleName+mnameFromList1 = MName . List1.toList++mnameToList1 :: ModuleName -> List1 Name+mnameToList1 (MName ns) = List1.ifNull ns __IMPOSSIBLE__ id+ noModuleName :: ModuleName noModuleName = mnameFromList []  commonParentModule :: ModuleName -> ModuleName -> ModuleName commonParentModule m1 m2 =-  mnameFromList $ commonPrefix (mnameToList m1) (mnameToList m2)+  mnameFromList $ L.commonPrefix (mnameToList m1) (mnameToList m2)  -- | Make a 'Name' from some kind of string. class MkName a where@@ -169,21 +186,25 @@   mkName_ = mkName noRange  instance MkName String where-  mkName r i s = Name i (C.Name noRange InScope (C.stringNameParts s)) r noFixity' False+  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 -qnameToList :: QName -> [Name]-qnameToList (QName m x) = mnameToList m ++ [x]+qnameToList0 :: QName -> [Name]+qnameToList0 = List1.toList . qnameToList -qnameFromList :: [Name] -> QName-qnameFromList [] = __IMPOSSIBLE__-qnameFromList xs = QName (mnameFromList $ init xs) (last xs)+qnameToList :: QName -> List1 Name+qnameToList (QName m x) = mnameToList m `List1.snoc` x +qnameFromList :: List1 Name -> QName+qnameFromList xs = QName (mnameFromList $ List1.init xs) (List1.last xs)+ qnameToMName :: QName -> ModuleName-qnameToMName = mnameFromList . qnameToList+qnameToMName = mnameFromList1 . qnameToList  mnameToQName :: ModuleName -> QName-mnameToQName = qnameFromList . mnameToList+mnameToQName = qnameFromList . mnameToList1  showQNameId :: QName -> String showQNameId q = show ns ++ "@" ++ show m@@ -195,14 +216,14 @@ -- | Turn a qualified name into a concrete name. This should only be used as a --   fallback when looking up the right concrete name in the scope fails. qnameToConcrete :: QName -> C.QName-qnameToConcrete (QName m x) =-  foldr C.Qual (C.QName $ nameConcrete x) $ map nameConcrete $ mnameToList m+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 xs) = foldr C.Qual (C.QName $ last cs) $ init cs+mnameToConcrete (MName (x:xs)) = foldr C.Qual (C.QName $ List1.last cs) $ List1.init cs   where-    cs = map nameConcrete xs+    cs = fmap nameConcrete (x :| xs)  -- | Computes the 'TopLevelModuleName' corresponding to the given -- module name, which is assumed to represent a top-level module name.@@ -211,13 +232,14 @@  toTopLevelModuleName :: ModuleName -> C.TopLevelModuleName toTopLevelModuleName (MName []) = __IMPOSSIBLE__-toTopLevelModuleName (MName ms) = C.TopLevelModuleName (getRange ms) $ map (C.nameToRawName . nameConcrete) ms+toTopLevelModuleName (MName ms) = List1.ifNull ms __IMPOSSIBLE__ {-else-} $ \ ms1 ->+  C.TopLevelModuleName (getRange ms1) $ fmap (C.nameToRawName . nameConcrete) ms1  qualifyM :: ModuleName -> ModuleName -> ModuleName qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2  qualifyQ :: ModuleName -> QName -> QName-qualifyQ m x = qnameFromList $ mnameToList m ++ qnameToList x+qualifyQ m x = qnameFromList $ mnameToList m `List1.prepend` qnameToList x  qualify :: ModuleName -> Name -> QName qualify = QName@@ -233,11 +255,12 @@  -- | Is the first module a weak parent of the second? isLeParentModuleOf :: ModuleName -> ModuleName -> Bool-isLeParentModuleOf = isPrefixOf `on` mnameToList+isLeParentModuleOf = List.isPrefixOf `on` mnameToList  -- | Is the first module a proper parent of the second? isLtParentModuleOf :: ModuleName -> ModuleName -> Bool-isLtParentModuleOf x y = isJust $ (stripPrefixBy (==) `on` mnameToList) x y+isLtParentModuleOf x y =+  isJust $ (L.stripPrefixBy (==) `on` mnameToList) x y  -- | Is the first module a weak child of the second? isLeChildModuleOf :: ModuleName -> ModuleName -> Bool@@ -248,12 +271,12 @@ isLtChildModuleOf = flip isLtParentModuleOf  isInModule :: QName -> ModuleName -> Bool-isInModule q m = mnameToList m `isPrefixOf` qnameToList q+isInModule q m = mnameToList m `List.isPrefixOf` qnameToList0 q  -- | Get the next version of the concrete name. For instance, @nextName "x" = "x₁"@. --   The name must not be a 'NoName'.-nextName :: Name -> Name-nextName x = x { nameConcrete = C.nextName (nameConcrete x) }+nextName :: C.FreshNameMode -> Name -> Name+nextName freshNameMode x = x { nameConcrete = C.nextName freshNameMode (nameConcrete x) }  sameRoot :: Name -> Name -> Bool sameRoot = C.sameRoot `on` nameConcrete@@ -347,31 +370,12 @@ -- | Use 'prettyShow' to print names to the user. ------------------------------------------------------------------------ --- deriving instance Show Name--- deriving instance Show ModuleName--- deriving instance Show QName+deriving instance Show Name+deriving instance Show ModuleName+deriving instance Show QName deriving instance Show a => Show (QNamed a) deriving instance Show AmbiguousQName --- | Only use this @show@ function in debugging!  To convert an---   abstract 'Name' into a string use @prettyShow@.-instance Show Name where-  -- Andreas, 2014-10-02: Reverted to nice printing.-  -- Reason: I do not have time just now to properly fix the-  -- use of Show Name for pretty printing everywhere.-  -- But I want to push the fix for Issue 836 now.-  show = prettyShow---- | Only use this @show@ function in debugging!  To convert an---   abstract 'ModuleName' into a string use @prettyShow@.-instance Show ModuleName where-  show = prettyShow---- | Only use this @show@ function in debugging!  To convert an---   abstract 'QName' into a string use @prettyShow@.-instance Show QName where-  show = prettyShow- nameToArgName :: Name -> ArgName nameToArgName = stringToArgName . prettyShow @@ -389,10 +393,14 @@   pretty = hcat . punctuate "." . map pretty . mnameToList  instance Pretty QName where-  pretty = hcat . punctuate "." . map pretty . qnameToList+  pretty = hcat . punctuate "." . map pretty . qnameToList0 . useCanonical+    where+      -- #4735: When printing a fully qualified name (as done by primShowQName) we need to+      -- use the origincal concrete name, not the possibly renamed concrete name in 'nameConcrete'.+      useCanonical q = q { qnameName = (qnameName q) { nameConcrete = nameCanonical (qnameName q) } }  instance Pretty AmbiguousQName where-  pretty (AmbQ qs) = hcat $ punctuate " | " $ map pretty (NonEmpty.toList qs)+  pretty (AmbQ qs) = hcat $ punctuate " | " $ map pretty $ List1.toList qs  instance Pretty a => Pretty (QNamed a) where   pretty (QNamed a b) = pretty a <> "." <> pretty b@@ -439,8 +447,8 @@ -- ** KillRange  instance KillRange Name where-  killRange (Name a b c d e) =-    (killRange4 Name a b c d e) { nameBindingSite = c }+  killRange (Name a b c d e f) =+    (killRange6 Name a b c d e f) { nameBindingSite = d }     -- Andreas, 2017-07-25, issue #2649     -- Preserve the nameBindingSite for error message.     --@@ -483,7 +491,7 @@ -- | The range is not forced.  instance NFData Name where-  rnf (Name _ a _ b c) = rnf a `seq` rnf b `seq` rnf c+  rnf (Name _ a b _ c d) = rnf (a, b, c, d)  instance NFData QName where   rnf (QName a b) = rnf a `seq` rnf b

src/full/Agda/Syntax/Abstract/Pattern.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE UndecidableInstances      #-}  -- | Auxiliary functions to handle patterns in the abstract syntax. --@@ -10,12 +8,9 @@ import Prelude hiding (null)  import Control.Arrow ((***), second)-import Control.Monad ((>=>)) import Control.Monad.Identity import Control.Applicative (liftA2) -import Data.Foldable (Foldable, foldMap)-import Data.Traversable (Traversable, traverse)  import Data.Maybe import Data.Monoid@@ -68,6 +63,7 @@       AsP i x p0         -> f $ updateNamedArg (AsP i x) $ mapNamedArgPattern f $ setNamedArg p p0       -- WithP: like AsP       WithP i p0         -> f $ updateNamedArg (WithP i) $ mapNamedArgPattern f $ setNamedArg p p0+      AnnP i a p0        -> f $ updateNamedArg (AnnP i a) $ mapNamedArgPattern f $ setNamedArg p p0  instance MapNamedArgPattern a => MapNamedArgPattern [a]                  where instance MapNamedArgPattern a => MapNamedArgPattern (FieldAssignment' a) where@@ -78,63 +74,66 @@  -- | Generic pattern traversal. -class APatternLike a p | p -> a where+class APatternLike p where+  type ADotT p    -- | Fold pattern.   foldrAPattern     :: Monoid m-    => (Pattern' a -> m -> m)+    => (Pattern' (ADotT p) -> m -> m)          -- ^ Combine a pattern and the value computed from its subpatterns.     -> p -> m    default foldrAPattern-    :: (Monoid m, Foldable f, APatternLike a b, f b ~ p)-    => (Pattern' a -> m -> m) -> p -> m+    :: (Monoid m, Foldable f, APatternLike b, (ADotT p) ~ (ADotT b), f b ~ p)+    => (Pattern' (ADotT p) -> m -> m) -> p -> m   foldrAPattern = foldMap . foldrAPattern    -- | Traverse pattern.   traverseAPatternM     :: Monad m-    => (Pattern' a -> m (Pattern' a))  -- ^ @pre@: Modification before recursion.-    -> (Pattern' a -> m (Pattern' a))  -- ^ @post@: Modification after recursion.+    => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @pre@: Modification before recursion.+    -> (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @post@: Modification after recursion.     -> p -> m p    default traverseAPatternM-    :: (Traversable f, APatternLike a q, f q ~ p, Monad m)-    => (Pattern' a -> m (Pattern' a))-    -> (Pattern' a -> m (Pattern' a))+    :: (Traversable f, APatternLike q, (ADotT p) ~ (ADotT q), f q ~ p, Monad m)+    => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))+    -> (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))     -> p -> m p   traverseAPatternM pre post = traverse $ traverseAPatternM pre post  -- | Compute from each subpattern a value and collect them all in a monoid. -foldAPattern :: (APatternLike a p, Monoid m) => (Pattern' a -> m) -> p -> m+foldAPattern :: (APatternLike p, Monoid m) => (Pattern' (ADotT p) -> m) -> p -> m foldAPattern f = foldrAPattern $ \ p m -> f p `mappend` m  -- | Traverse pattern(s) with a modification before the recursive descent.  preTraverseAPatternM-  :: (APatternLike a b, Monad m )-  => (Pattern' a -> m (Pattern' a))  -- ^ @pre@: Modification before recursion.-  -> b -> m b+  :: (APatternLike p, Monad m )+  => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @pre@: Modification before recursion.+  -> p -> m p preTraverseAPatternM pre p = traverseAPatternM pre return p  -- | Traverse pattern(s) with a modification after the recursive descent.  postTraverseAPatternM-  :: (APatternLike a b, Monad m)-  => (Pattern' a -> m (Pattern' a))  -- ^ @post@: Modification after recursion.-  -> b -> m b+  :: (APatternLike p, Monad m )+  => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @post@: Modification after recursion.+  -> p -> m p postTraverseAPatternM post p = traverseAPatternM return post p  -- | Map pattern(s) with a modification after the recursive descent. -mapAPattern :: APatternLike a p => (Pattern' a -> Pattern' a) -> p -> p+mapAPattern :: APatternLike p => (Pattern' (ADotT p) -> Pattern' (ADotT p)) -> p -> p mapAPattern f = runIdentity . postTraverseAPatternM (Identity . f)  -- Interesting instance: -instance APatternLike a (Pattern' a) where+instance APatternLike (Pattern' a) where+  type ADotT (Pattern' a) = a+   foldrAPattern f p = f p $     case p of       AsP _ _ p          -> foldrAPattern f p@@ -148,20 +147,21 @@       WildP _            -> mempty       DotP _ _           -> mempty       AbsurdP _          -> mempty-      LitP _             -> mempty+      LitP _ _           -> mempty       EqualP _ _         -> mempty+      AnnP _ _ p         -> foldrAPattern f p    traverseAPatternM pre post = pre >=> recurse >=> post     where-    recurse p = case p of+    recurse = \case       -- Non-recursive cases:-      A.VarP{}             -> return p-      A.WildP{}            -> return p-      A.DotP{}             -> return p-      A.LitP{}             -> return p-      A.AbsurdP{}          -> return p-      A.ProjP{}            -> return p-      A.EqualP{}           -> return p+      p@A.VarP{}            -> return p+      p@A.WildP{}           -> return p+      p@A.DotP{}            -> return p+      p@A.LitP{}            -> return p+      p@A.AbsurdP{}         -> return p+      p@A.ProjP{}           -> return p+      p@A.EqualP{}          -> return p       -- Recursive cases:       A.ConP        i ds ps -> A.ConP        i ds <$> traverseAPatternM pre post ps       A.DefP        i q  ps -> A.DefP        i q  <$> traverseAPatternM pre post ps@@ -169,17 +169,26 @@       A.RecP        i    ps -> A.RecP        i    <$> traverseAPatternM pre post ps       A.PatternSynP i x  ps -> A.PatternSynP i x  <$> traverseAPatternM pre post ps       A.WithP       i p     -> A.WithP       i    <$> traverseAPatternM pre post p+      A.AnnP        i a  p  -> A.AnnP        i a  <$> traverseAPatternM pre post p --- The following instances need UndecidableInstances--- for the FunctionalDependency (since injectivity is not taken into account).+instance APatternLike a => APatternLike (Arg a) where+  type ADotT (Arg a) = ADotT a -instance APatternLike a b => APatternLike a (Arg b)              where-instance APatternLike a b => APatternLike a (Named n b)          where-instance APatternLike a b => APatternLike a [b]                  where-instance APatternLike a b => APatternLike a (Maybe b)            where-instance APatternLike a b => APatternLike a (FieldAssignment' b) where+instance APatternLike a => APatternLike (Named n a) where+  type ADotT (Named n a) = ADotT a -instance (APatternLike a b, APatternLike a c) => APatternLike a (b,c) where+instance APatternLike a => APatternLike [a] where+  type ADotT [a] = ADotT a++instance APatternLike a => APatternLike (Maybe a) where+  type ADotT (Maybe a) = ADotT a++instance APatternLike a => APatternLike (FieldAssignment' a) where+  type ADotT (FieldAssignment' a) = ADotT a++instance (APatternLike a, APatternLike b, ADotT a ~ ADotT b) => APatternLike (a, b) where+  type ADotT (a, b) = ADotT a+   foldrAPattern f (p, p') =     foldrAPattern f p `mappend` foldrAPattern f p' @@ -194,7 +203,7 @@  -- | Collect pattern variables in left-to-right textual order. -patternVars :: forall a p. APatternLike a p => p -> [A.Name]+patternVars :: APatternLike p => p -> [A.Name] patternVars p = foldAPattern f p `appEndo` []   where   -- We use difference lists @[A.Name] -> [A.Name]@ to avoid reconcatenation.@@ -213,10 +222,11 @@     A.EqualP      {} -> mempty     A.PatternSynP {} -> mempty     A.WithP _ _      -> mempty+    A.AnnP        {} -> mempty  -- | Check if a pattern contains a specific (sub)pattern. -containsAPattern :: APatternLike a p => (Pattern' a -> Bool) -> p -> Bool+containsAPattern :: APatternLike p => (Pattern' (ADotT p) -> Bool) -> p -> Bool containsAPattern f = getAny . foldAPattern (Any . f)  -- | Check if a pattern contains an absurd pattern.@@ -224,7 +234,7 @@ -- --   Precondition: contains no pattern synonyms. -containsAbsurdPattern :: APatternLike a p => p -> Bool+containsAbsurdPattern :: APatternLike p => p -> Bool containsAbsurdPattern = containsAPattern $ \case     A.PatternSynP{} -> __IMPOSSIBLE__     A.AbsurdP{}     -> True@@ -232,17 +242,14 @@  -- | Check if a pattern contains an @-pattern. -----   Precondition: contains no pattern synonyms.--containsAsPattern :: APatternLike a p => p -> Bool+containsAsPattern :: APatternLike p => p -> Bool containsAsPattern = containsAPattern $ \case-    A.PatternSynP{} -> __IMPOSSIBLE__     A.AsP{}         -> True     _               -> False  -- | Check if any user-written pattern variables occur more than once, --   and throw the given error if they do.-checkPatternLinearity :: (Monad m, APatternLike a p)+checkPatternLinearity :: (Monad m, APatternLike p)                       => p -> ([C.Name] -> m ()) -> m () checkPatternLinearity ps err =   unlessNull (duplicates $ map nameConcrete $ patternVars ps) $ \ys -> err ys@@ -270,13 +277,14 @@   VarP x            -> fromMaybe p $ lookup (A.unBind x) s   DotP i e          -> DotP i $ subE e   EqualP i es       -> EqualP i $ map (subE *** subE) es+  AnnP i a p        -> AnnP i (subE a) p   -- No action on the other patterns (besides the recursion):   ConP _ _ _        -> p   RecP _ _          -> p   ProjP _ _ _       -> p   WildP _           -> p   AbsurdP _         -> p-  LitP _            -> p+  LitP _ _          -> p   DefP _ _ _        -> p   AsP _ _ _         -> p -- Note: cannot substitute into as-variable   PatternSynP _ _ _ -> p@@ -360,8 +368,11 @@   LHSHead f ps     -> QNamed f ps   LHSProj d h ps   -> lhsCoreToSpine (namedArg h) <&> (++ (p : ps))     where p = updateNamedArg (const $ ProjP empty ProjPrefix d) h-  LHSWith h wps ps -> lhsCoreToSpine h <&> (++ map (defaultNamedArg . mkWithP) wps ++ ps)-    where mkWithP p = WithP (PatRange $ getRange p) p+  LHSWith h wps ps -> lhsCoreToSpine h <&> (++ map fromWithPat wps ++ ps)+    where+      fromWithPat :: Arg (Pattern' e) -> NamedArg (Pattern' e)+      fromWithPat = fmap (unnamed . mkWithP)+      mkWithP p   = WithP (PatRange $ getRange p) p  spineToLhsCore :: IsProjP e => QNamed [NamedArg (Pattern' e)] -> LHSCore' e spineToLhsCore (QNamed f ps) = lhsCoreAddSpine (LHSHead f []) ps@@ -371,14 +382,14 @@ lhsCoreApp core ps = core { lhsPats = lhsPats core ++ ps }  -- | Add with-patterns to the right.-lhsCoreWith :: LHSCore' e -> [Pattern' e] -> LHSCore' e+lhsCoreWith :: LHSCore' e -> [Arg (Pattern' e)] -> LHSCore' e 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 core = \case   LHSAppP ps               -> lhsCoreApp core ps-  LHSWithP wps             -> lhsCoreWith core wps+  LHSWithP wps             -> lhsCoreWith core (defaultArg <$> wps)   LHSProjP ProjPrefix d np -> LHSProj d (setNamedArg np core) []  -- Prefix projection pattern.   LHSProjP _          _ np -> lhsCoreApp core [np]       -- Postfix projection pattern. @@ -414,7 +425,11 @@     LHSProj d lhscore aps -> DefP noInfo d $       fmap (fmap lhsCoreToPattern) lhscore : aps     LHSWith h wps aps     -> case lhsCoreToPattern h of-      DefP r q ps         -> DefP r q $ ps ++ map (\ p -> defaultNamedArg $ WithP (PatRange $ getRange p) p) wps ++ aps+      DefP r q ps         -> DefP r q $ ps ++ map fromWithPat wps ++ aps+        where+          fromWithPat :: Arg Pattern -> NamedArg Pattern+          fromWithPat = fmap (unnamed . mkWithP)+          mkWithP p   = WithP (PatRange $ getRange p) p       _ -> __IMPOSSIBLE__   where noInfo = empty -- TODO, preserve range!

src/full/Agda/Syntax/Abstract/PatternSynonyms.hs view

@@ -15,19 +15,19 @@ import qualified Data.Map as Map import Data.Traversable (forM) import Data.List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.Void  import Agda.Syntax.Common import Agda.Syntax.Abstract 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 --   names).-mergePatternSynDefs :: NonEmpty PatternSynDefn -> Maybe PatternSynDefn+mergePatternSynDefs :: List1 PatternSynDefn -> Maybe PatternSynDefn mergePatternSynDefs (def :| defs) = foldM mergeDef def defs  mergeDef :: PatternSynDefn -> PatternSynDefn -> Maybe PatternSynDefn@@ -36,27 +36,25 @@   let ren = zip (map unArg xs) (map unArg ys)   (xs,) <$> merge ren p q   where-    merge ren p@(VarP x) (VarP y)   = p <$ guard (elem (unBind x, unBind y) ren)-    merge ren p@(LitP l) (LitP l')  = p <$ guard (l == l')+    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       guard $ map getArgInfo ps == map getArgInfo qs-      ConP i (AmbQ $ unionNe cs cs') <$> zipWithM (mergeArg ren) ps qs+      ConP i (AmbQ $ List1.union cs cs') <$> zipWithM (mergeArg ren) ps qs     merge _ _ _ = empty      mergeArg ren p q = setNamedArg p <$> merge ren (namedArg p) (namedArg q) -    unionNe xs ys = NonEmpty.fromList $ NonEmpty.toList xs `union` NonEmpty.toList ys- -- | Match an expression against a pattern synonym. matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [Arg Expr] matchPatternSyn = runMatch match   where     match (VarP x) e = unBind x ==> e-    match (LitP l) (Lit l') = guard (l == l')+    match (LitP _ l) (Lit _ l') = guard (l == l')     match (ConP _ (AmbQ cs) ps) e = do       Application (Con (AmbQ cs')) args <- return (appView e)-      guard $ null (NonEmpty.toList cs' \\ NonEmpty.toList cs)            -- check all possible constructors appear in the synonym+      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?)       zipWithM_ match (map namedArg ps) (map namedArg args)     match _ _ = empty@@ -66,10 +64,10 @@ matchPatternSynP = runMatch match   where     match (VarP x) q = unBind x ==> q-    match (LitP l) (LitP l') = guard (l == l')+    match (LitP _ l) (LitP _ l') = guard (l == l')     match (WildP _) (WildP _) = return ()     match (ConP _ (AmbQ cs) ps) (ConP _ (AmbQ cs') qs) = do-      guard $ null (NonEmpty.toList cs' \\ NonEmpty.toList cs)+      guard $ all (`elem` cs) cs'       guard $ map getArgInfo ps == map getArgInfo qs       zipWithM_ match (map namedArg ps) (map namedArg qs)     match _ _ = empty

src/full/Agda/Syntax/Abstract/Pretty.hs view

@@ -5,21 +5,21 @@ import Agda.Syntax.Translation.AbstractToConcrete import Agda.Utils.Pretty -showA :: (Show c, ToConcrete a c, MonadAbsToCon m) => a -> m String+showA :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String showA x = show <$> abstractToConcrete_ x -prettyA :: (Pretty c, ToConcrete a c, MonadAbsToCon m) => a -> m Doc+prettyA :: (ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc prettyA x = pretty <$> abstractToConcrete_ x -prettyAs :: (Pretty c, ToConcrete a [c], MonadAbsToCon m) => a -> m Doc+prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], Pretty ce, MonadAbsToCon m) => a -> m Doc prettyAs x = fsep . map pretty <$> abstractToConcrete_ x  -- | Variant of 'showA' which does not insert outermost parentheses. -showATop :: (Show c, ToConcrete a c, MonadAbsToCon m) => a -> m String+showATop :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String showATop x = show <$> abstractToConcreteCtx TopCtx x  -- | Variant of 'prettyA' which does not insert outermost parentheses. -prettyATop :: (Pretty c, ToConcrete a c, MonadAbsToCon m) => a -> m Doc+prettyATop :: (ToConcrete a, Pretty (ConOfAbs a),  MonadAbsToCon m) => a -> m Doc prettyATop x = pretty <$> abstractToConcreteCtx TopCtx x

src/full/Agda/Syntax/Abstract/Views.hs view

@@ -1,23 +1,30 @@-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonoLocalBinds          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}  module Agda.Syntax.Abstract.Views where +import Prelude hiding (null)+ import Control.Applicative ( Const(Const), getConst ) import Control.Arrow (first) import Control.Monad.Identity +import Data.Foldable (foldMap)+import Data.Semigroup ((<>)) import Data.Void  import Agda.Syntax.Common import Agda.Syntax.Abstract as A import Agda.Syntax.Concrete (FieldAssignment', exprFieldA) import Agda.Syntax.Info-import Agda.Syntax.Scope.Base (emptyScopeInfo)+import Agda.Syntax.Scope.Base (KindOfName(..), conKindOfName, WithKind(..))  import Agda.Utils.Either+import Agda.Utils.List1 (List1)+import Agda.Utils.Null+import Agda.Utils.Singleton +import Agda.Utils.Impossible++ data AppView' arg = Application Expr [NamedArg arg]   deriving (Functor) @@ -63,23 +70,17 @@ lamView (ScopedExpr _ e) = lamView e lamView e = LamView [] e --- | Gather top-level 'AsP'atterns to expose underlying pattern.-asView :: A.Pattern -> ([Name], A.Pattern)-asView (A.AsP _ x p) = first (unBind x :) $ asView p-asView p             = ([], p)---- | Check whether we are dealing with a universe.-isSet :: Expr -> Bool-isSet (ScopedExpr _ e) = isSet e-isSet (App _ e _)      = isSet e-isSet (Set{})          = True-isSet _                = False+-- | Gather top-level 'AsP'atterns and 'AnnP'atterns to expose underlying pattern.+asView :: A.Pattern -> ([Name], [A.Expr], A.Pattern)+asView (A.AsP _ x p)  = (\(asb, ann, p) -> (unBind x : asb, ann, p)) $ asView p+asView (A.AnnP _ a p) = (\(asb, ann, p) -> (asb, a : ann, p))        $ asView p+asView p              = ([], [], p)  -- | Remove top 'ScopedExpr' wrappers. unScope :: Expr -> Expr unScope (ScopedExpr scope e) = unScope e-unScope (QuestionMark i ii)  = QuestionMark (i {metaScope = emptyScopeInfo}) ii-unScope (Underscore i)       = Underscore (i {metaScope = emptyScopeInfo})+unScope (QuestionMark i ii)  = QuestionMark (i {metaScope = empty}) ii+unScope (Underscore i)       = Underscore (i {metaScope = empty}) unScope e                    = e  -- | Remove 'ScopedExpr' wrappers everywhere.@@ -96,139 +97,154 @@ deepUnscopeDecl (A.ScopedDecl _ ds)              = deepUnscopeDecls ds deepUnscopeDecl (A.Mutual i ds)                  = [A.Mutual i (deepUnscopeDecls ds)] deepUnscopeDecl (A.Section i m tel ds)           = [A.Section i m (deepUnscope tel) (deepUnscopeDecls ds)]-deepUnscopeDecl (A.RecDef i x uc ind eta c bs e ds) = [A.RecDef i x uc ind eta c (deepUnscope bs) (deepUnscope e)-                                                                           (deepUnscopeDecls ds)]+deepUnscopeDecl (A.RecDef i x uc dir bs e ds) =+  [ A.RecDef i x uc dir (deepUnscope bs) (deepUnscope e) (deepUnscopeDecls ds) ] deepUnscopeDecl d                                = [deepUnscope d]  -- * Traversal+--------------------------------------------------------------------------- +-- Type aliases to abbreviate the quantified foralls which we use to avoid+-- giving in to NoMonoLocalBinds.+type RecurseExprFn m a = Applicative m => (Expr -> m Expr -> m Expr) -> a -> m a+type RecurseExprRecFn m = forall a. ExprLike a => a -> m a++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 TraverseExprRecFn m = forall a. ExprLike a => a -> m a+ -- | Apply an expression rewriting to every subexpression, inside-out. --   See "Agda.Syntax.Internal.Generic". class ExprLike a where   -- | The first expression is pre-traversal, the second one post-traversal.-  recurseExpr :: (Applicative m) => (Expr -> m Expr -> m Expr) -> a -> m a+  recurseExpr :: RecurseExprFn m a   default recurseExpr :: (Traversable f, ExprLike a', a ~ f a', Applicative m)                       => (Expr -> m Expr -> m Expr) -> a -> m a   recurseExpr = traverse . recurseExpr -  foldExpr :: Monoid m => (Expr -> m) -> a -> m+  foldExpr :: FoldExprFn m a   foldExpr f = getConst . recurseExpr (\ pre post -> Const (f pre) <* post) -  traverseExpr :: (Applicative m, Monad m) => (Expr -> m Expr) -> a -> m a+  traverseExpr :: TraverseExprFn m a   traverseExpr f = recurseExpr (\ pre post -> f =<< post)    mapExpr :: (Expr -> Expr) -> (a -> a)   mapExpr f = runIdentity . traverseExpr (Identity . f)  instance ExprLike Expr where+  recurseExpr :: forall m. RecurseExprFn m Expr   recurseExpr f e0 = f e0 $ do-    let recurse e = recurseExpr f e+    let+      recurse :: RecurseExprRecFn m+      recurse e = recurseExpr f e     case e0 of-      Var{}                   -> pure e0-      Def{}                   -> pure e0-      Proj{}                  -> pure e0-      Con{}                   -> pure e0-      Lit{}                   -> pure e0-      QuestionMark{}          -> pure e0-      Underscore{}            -> pure e0-      Dot ei e                -> Dot ei <$> recurse e-      App ei e arg            -> App ei <$> recurse e <*> recurse arg-      WithApp ei e es         -> WithApp ei <$> recurse e <*> recurse es-      Lam ei b e              -> Lam ei <$> recurse b <*> recurse e-      AbsurdLam{}             -> pure e0-      ExtendedLam ei di x cls -> ExtendedLam ei di x <$> recurse cls-      Pi ei tel e             -> Pi ei <$> recurse tel <*> recurse e-      Generalized  s e        -> Generalized s <$> recurse e-      Fun ei arg e            -> Fun ei <$> recurse arg <*> recurse e-      Set{}                   -> pure e0-      Prop{}                  -> pure e0-      Let ei bs e             -> Let ei <$> recurse bs <*> recurse e-      ETel tel                -> ETel <$> recurse tel-      Rec ei bs               -> Rec ei <$> recurse bs-      RecUpdate ei e bs       -> RecUpdate ei <$> recurse e <*> recurse bs-      ScopedExpr sc e         -> ScopedExpr sc <$> recurse e-      Quote{}                 -> pure e0-      QuoteTerm{}             -> pure e0-      Unquote{}               -> pure e0-      DontCare e              -> DontCare <$> recurse e-      PatternSyn{}            -> pure e0-      Tactic ei e xs          -> Tactic ei <$> recurse e <*> recurse xs-      Macro{}                 -> pure e0+      Var{}                      -> pure e0+      Def'{}                     -> pure e0+      Proj{}                     -> pure e0+      Con{}                      -> pure e0+      Lit{}                      -> pure e0+      QuestionMark{}             -> pure e0+      Underscore{}               -> pure e0+      Dot ei e                   -> Dot ei <$> recurse e+      App ei e arg               -> App ei <$> recurse e <*> recurse arg+      WithApp ei e es            -> WithApp ei <$> recurse e <*> recurse es+      Lam ei b e                 -> Lam ei <$> recurse b <*> recurse e+      AbsurdLam{}                -> pure e0+      ExtendedLam ei di er x cls -> ExtendedLam ei di er x <$> recurse cls+      Pi ei tel e                -> Pi ei <$> recurse tel <*> recurse e+      Generalized  s e           -> Generalized s <$> recurse e+      Fun ei arg e               -> Fun ei <$> recurse arg <*> recurse e+      Let ei bs e                -> Let ei <$> recurse bs <*> recurse e+      ETel tel                   -> ETel <$> recurse tel+      Rec ei bs                  -> Rec ei <$> recurse bs+      RecUpdate ei e bs          -> RecUpdate ei <$> recurse e <*> recurse bs+      ScopedExpr sc e            -> ScopedExpr sc <$> recurse e+      Quote{}                    -> pure e0+      QuoteTerm{}                -> pure e0+      Unquote{}                  -> pure e0+      DontCare e                 -> DontCare <$> recurse e+      PatternSyn{}               -> pure e0+      Tactic ei e xs             -> Tactic ei <$> recurse e <*> recurse xs+      Macro{}                    -> pure e0 +  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'-      Set{}                -> m-      Prop{}               -> m-      Let _ bs e           -> m `mappend` fold bs `mappend` fold e-      ETel tel             -> m `mappend` fold tel-      Rec _ as             -> m `mappend` fold as-      RecUpdate _ e as     -> m `mappend` fold e `mappend` fold as-      ScopedExpr _ e       -> m `mappend` fold e-      Quote{}              -> m-      QuoteTerm{}          -> m-      Unquote{}            -> m-      Tactic _ e xs        -> m `mappend` fold e `mappend` fold xs-      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+      ETel tel               -> m `mappend` fold tel+      Rec _ as               -> m `mappend` fold as+      RecUpdate _ e as       -> m `mappend` fold e `mappend` fold as+      ScopedExpr _ e         -> m `mappend` fold e+      Quote{}                -> m+      QuoteTerm{}            -> m+      Unquote{}              -> m+      Tactic _ e xs          -> m `mappend` fold e `mappend` fold xs+      DontCare e             -> m `mappend` fold e    where-     m    = f e+     m = f e+     fold :: FoldExprRecFn m      fold = foldExpr f +  traverseExpr :: forall m. TraverseExprFn m Expr   traverseExpr f e = do-    let trav e = traverseExpr f e+    let+      trav :: TraverseExprRecFn m+      trav e = traverseExpr f e     case e of-      Var{}                   -> f e-      Def{}                   -> f e-      Proj{}                  -> f e-      Con{}                   -> f e-      Lit{}                   -> f e-      QuestionMark{}          -> f e-      Underscore{}            -> f e-      Dot ei e                -> f =<< Dot ei <$> trav e-      App ei e arg            -> f =<< App ei <$> trav e <*> trav arg-      WithApp ei e es         -> f =<< WithApp ei <$> trav e <*> trav es-      Lam ei b e              -> f =<< Lam ei <$> trav b <*> trav e-      AbsurdLam{}             -> f e-      ExtendedLam ei di x cls -> f =<< ExtendedLam ei di x <$> trav cls-      Pi ei tel e             -> f =<< Pi ei <$> trav tel <*> trav e-      Generalized s e         -> f =<< Generalized s <$> trav e-      Fun ei arg e            -> f =<< Fun ei <$> trav arg <*> trav e-      Set{}                   -> f e-      Prop{}                  -> f e-      Let ei bs e             -> f =<< Let ei <$> trav bs <*> trav e-      ETel tel                -> f =<< ETel <$> trav tel-      Rec ei bs               -> f =<< Rec ei <$> trav bs-      RecUpdate ei e bs       -> f =<< RecUpdate ei <$> trav e <*> trav bs-      ScopedExpr sc e         -> f =<< ScopedExpr sc <$> trav e-      Quote{}                 -> f e-      QuoteTerm{}             -> f e-      Unquote{}               -> f e-      Tactic ei e xs          -> f =<< Tactic ei <$> trav e <*> trav xs-      DontCare e              -> f =<< DontCare <$> trav e-      PatternSyn{}            -> f e-      Macro{}                 -> f e+      Var{}                      -> f e+      Def'{}                     -> f e+      Proj{}                     -> f e+      Con{}                      -> f e+      Lit{}                      -> f e+      QuestionMark{}             -> f e+      Underscore{}               -> f e+      Dot ei e                   -> f =<< Dot ei <$> trav e+      App ei e arg               -> f =<< App ei <$> trav e <*> trav arg+      WithApp ei e es            -> f =<< WithApp ei <$> trav e <*> trav es+      Lam ei b e                 -> f =<< Lam ei <$> trav b <*> trav e+      AbsurdLam{}                -> f e+      ExtendedLam ei di re x cls -> f =<< ExtendedLam ei di re x <$> trav cls+      Pi ei tel e                -> f =<< Pi ei <$> trav tel <*> trav e+      Generalized s e            -> f =<< Generalized s <$> trav e+      Fun ei arg e               -> f =<< Fun ei <$> trav arg <*> trav e+      Let ei bs e                -> f =<< Let ei <$> trav bs <*> trav e+      ETel tel                   -> f =<< ETel <$> trav tel+      Rec ei bs                  -> f =<< Rec ei <$> trav bs+      RecUpdate ei e bs          -> f =<< RecUpdate ei <$> trav e <*> trav bs+      ScopedExpr sc e            -> f =<< ScopedExpr sc <$> trav e+      Quote{}                    -> f e+      QuoteTerm{}                -> f e+      Unquote{}                  -> f e+      Tactic ei e xs             -> f =<< Tactic ei <$> trav e <*> trav xs+      DontCare e                 -> f =<< DontCare <$> trav e+      PatternSyn{}               -> f e+      Macro{}                    -> f e -instance ExprLike a => ExprLike (Arg a)     where-instance ExprLike a => ExprLike (Maybe a)   where-instance ExprLike a => ExprLike (Named x a) where-instance ExprLike a => ExprLike [a]         where+instance ExprLike a => ExprLike (Arg a)+instance ExprLike a => ExprLike (Maybe a)+instance ExprLike a => ExprLike (Named x a)+instance ExprLike a => ExprLike [a]+instance ExprLike a => ExprLike (List1 a)  instance (ExprLike a, ExprLike b) => ExprLike (a, b) where   recurseExpr f (x, y) = (,) <$> recurseExpr f x <*> recurseExpr f y@@ -243,6 +259,9 @@   recurseExpr f = traverseEither (recurseExpr f)                                  (recurseExpr f) +instance ExprLike BindName where+  recurseExpr f = pure+ instance ExprLike ModuleName where   recurseExpr f = pure @@ -288,8 +307,11 @@       TLet r ds      -> TLet r <$> traverseExpr f ds  instance ExprLike LetBinding where+  recurseExpr :: forall m. RecurseExprFn m LetBinding   recurseExpr f e = do-    let recurse e = recurseExpr f e+    let+      recurse :: RecurseExprRecFn m+      recurse e = recurseExpr f e     case e of       LetBind li ai x e e'  -> LetBind li ai x <$> recurse e <*> recurse e'       LetPatBind li p e     -> LetPatBind li <$> recurse p <*> recurse e@@ -297,6 +319,7 @@       LetOpen{}             -> pure e       LetDeclaredVariable _ -> pure e +  foldExpr :: forall m. FoldExprFn m LetBinding   foldExpr f e =     case e of       LetBind _ _ _ e e'    -> fold e `mappend` fold e'@@ -304,10 +327,15 @@       LetApply{}            -> mempty       LetOpen{}             -> mempty       LetDeclaredVariable _ -> mempty-    where fold e = foldExpr f e+    where+      fold :: FoldExprRecFn m+      fold e = foldExpr f e +  traverseExpr :: forall m. TraverseExprFn m LetBinding   traverseExpr f e = do-    let trav e = traverseExpr f e+    let+      trav :: TraverseExprRecFn m+      trav e = traverseExpr f e     case e of       LetBind li ai x e e'  -> LetBind li ai x <$> trav e <*> trav e'       LetPatBind li p e     -> LetPatBind li <$> trav p <*> trav e@@ -318,19 +346,25 @@ instance ExprLike a => ExprLike (Pattern' a) where  instance ExprLike a => ExprLike (Clause' a) where+  recurseExpr :: forall m. RecurseExprFn m (Clause' a)   recurseExpr f (Clause lhs spats rhs ds ca) = Clause <$> rec lhs <*> pure spats <*> rec rhs <*> rec ds <*> pure ca-    where rec = recurseExpr f+    where+      rec :: RecurseExprRecFn m+      rec = recurseExpr f  instance ExprLike RHS where+  recurseExpr :: forall m. RecurseExprFn m RHS   recurseExpr f rhs =     case rhs of       RHS e c                 -> RHS <$> rec e <*> pure c       AbsurdRHS{}             -> pure rhs       WithRHS x es cs         -> WithRHS x <$> rec es <*> rec cs       RewriteRHS xes spats rhs ds -> RewriteRHS <$> rec xes <*> pure spats <*> rec rhs <*> rec ds-    where rec e = recurseExpr f e+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e -instance (ExprLike qn, ExprLike p, ExprLike e) => ExprLike (RewriteEqn' qn p e) where+instance (ExprLike qn, ExprLike nm, 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@@ -339,13 +373,17 @@   recurseExpr f (WhereDecls a b) = WhereDecls a <$> recurseExpr f b  instance ExprLike ModuleApplication where+  recurseExpr :: forall m. RecurseExprFn m ModuleApplication   recurseExpr f a =     case a of       SectionApp tel m es -> SectionApp <$> rec tel <*> rec m <*> rec es       RecordModuleInstance{} -> pure a-    where rec e = recurseExpr f e+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e  instance ExprLike Pragma where+  recurseExpr :: forall m. RecurseExprFn m Pragma   recurseExpr f p =     case p of       BuiltinPragma s x           -> pure p@@ -358,7 +396,9 @@       InlinePragma{}              -> pure p       EtaPragma{}                 -> pure p       DisplayPragma f xs e        -> DisplayPragma f <$> rec xs <*> rec e-    where rec e = recurseExpr f e+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e  instance ExprLike LHS where   recurseExpr f (LHS i p) = LHS i <$> recurseExpr f p@@ -370,6 +410,7 @@   recurseExpr f (SpineLHS i x ps) = SpineLHS i x <$> recurseExpr f ps  instance ExprLike Declaration where+  recurseExpr :: forall m. RecurseExprFn m Declaration   recurseExpr f d =     case d of       Axiom a d i mp x e        -> Axiom a d i mp x <$> rec e@@ -386,9 +427,184 @@       DataSig i d tel e         -> DataSig i d <$> rec tel <*> rec e       DataDef i d uc bs cs      -> DataDef i d uc <$> rec bs <*> rec cs       RecSig i r tel e          -> RecSig i r <$> rec tel <*> rec e-      RecDef i r uc n co c bs e ds -> RecDef i r uc n co c <$> rec bs <*> rec e <*> rec ds+      RecDef i r uc dir bs e ds -> RecDef i r uc 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       ScopedDecl s ds           -> ScopedDecl s <$> rec ds-    where rec e = recurseExpr f e+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e+++-- * Getting all declared names+---------------------------------------------------------------------------++type KName = WithKind QName++-- | Extracts "all" names which are declared in a 'Declaration'.+--+-- Includes: local modules and @where@ clauses.+-- Excludes: @open public@, @let@, @with@ function names, extended lambdas.++class DeclaredNames a where+  declaredNames :: Collection KName m => a -> m++  default declaredNames+     :: (Foldable t, DeclaredNames b, t b ~ a)+     => Collection KName m => a -> m+  declaredNames = foldMap declaredNames++instance DeclaredNames a => DeclaredNames [a]+instance DeclaredNames a => DeclaredNames (List1 a)+instance DeclaredNames a => DeclaredNames (Maybe a)+instance DeclaredNames a => DeclaredNames (Arg a)+instance DeclaredNames a => DeclaredNames (Named name a)+instance DeclaredNames a => DeclaredNames (FieldAssignment' a)++instance (DeclaredNames a, DeclaredNames b) => DeclaredNames (Either a b) where+  declaredNames = either declaredNames declaredNames++instance (DeclaredNames a, DeclaredNames b) => DeclaredNames (a,b) where+  declaredNames (a,b) = declaredNames a <> declaredNames b++instance DeclaredNames KName where+  declaredNames = singleton++instance DeclaredNames RecordDirectives where+  declaredNames (RecordDirectives i _ _ c) = kc where+    kc = maybe mempty (singleton . WithKind k) c+    k  = maybe ConName (conKindOfName . rangedThing) i++instance DeclaredNames Declaration where+  declaredNames = \case+      Axiom _ di _ _ q _           -> singleton . (`WithKind` q) $+                                      case defMacro di of+                                        MacroDef    -> MacroName+                                        NotMacroDef -> AxiomName+      Generalize _ _ _ q _         -> singleton (WithKind GeneralizeName q)+      Field _ q _                  -> singleton (WithKind FldName q)+      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+      RecSig _ q _ _               -> singleton (WithKind RecName q)+      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+      FunDef _ q _ cls             -> singleton (WithKind FunName q) <> declaredNames cls+      ScopedDecl _ decls           -> declaredNames decls+      Section _ _ _ decls          -> declaredNames decls+      Pragma _ pragma              -> declaredNames pragma+      Apply{}                      -> mempty+      Import{}                     -> mempty+      Open{}                       -> mempty+    where+    con = \case+      Axiom _ _ _ _ q _ -> singleton $ WithKind ConName q+      _ -> __IMPOSSIBLE__++instance DeclaredNames Pragma where+  declaredNames = \case+    BuiltinNoDefPragma _b kind x -> singleton $ WithKind kind x+    BuiltinPragma{}         -> mempty+    CompilePragma{}         -> mempty+    RewritePragma{}         -> mempty+    StaticPragma{}          -> mempty+    EtaPragma{}             -> mempty+    InjectivePragma{}       -> mempty+    InlinePragma{}          -> mempty+    DisplayPragma{}         -> mempty+    OptionsPragma{}         -> mempty++instance DeclaredNames Clause where+  declaredNames (Clause _ _ rhs decls _) = declaredNames rhs <> declaredNames decls++instance DeclaredNames WhereDeclarations where+  declaredNames (WhereDecls _ ds) = declaredNames ds++instance DeclaredNames RHS where+  declaredNames = \case+    RHS _ _                   -> mempty+    AbsurdRHS                 -> mempty+    WithRHS _q _es cls        -> declaredNames cls+    RewriteRHS _qes _ rhs cls -> declaredNames rhs <> declaredNames cls++-- Andreas, 2020-04-13: Migration from Agda.Syntax.Abstract.AllNames+--+-- Since we are not interested in names of extended lambdas, we do not+-- traverse into expression.+--+-- However, we keep this code (originally Agda.Syntax.Abstract.AllNames) around+-- should arise a need to collect extended lambda names.++-- instance (DeclaredNames a, DeclaredNames b, DeclaredNames c) => DeclaredNames (a,b,c) where+--   declaredNames (a,b,c) = declaredNames a <> declaredNames b <> declaredNames c++-- instance DeclaredNames RHS where+--   declaredNames = \case+--     RHS e _                  -> declaredNames e+--     AbsurdRHS{}              -> mempty+--     WithRHS q _ cls          -> singleton (WithKind FunName q) <> declaredNames cls+--     RewriteRHS qes _ rhs cls -> declaredNames (qes, rhs, cls)++-- instance DeclaredNames ModuleName where+--   declaredNames _ = mempty++-- instance (DeclaredNames qn, DeclaredNames e) => DeclaredNames (RewriteEqn' qn p e) where+--   declaredNames = \case+--     Rewrite es    -> declaredNames es+--     Invert qn pes -> declaredNames qn <> declaredNames pes++-- instance DeclaredNames Expr where+--   declaredNames = \case+--     Var{}                 -> mempty+--     Def{}                 -> mempty+--     Proj{}                -> mempty+--     Con{}                 -> mempty+--     Lit{}                 -> mempty+--     QuestionMark{}        -> mempty+--     Underscore{}          -> mempty+--     Dot _ e               -> declaredNames e+--     App _ e1 e2           -> declaredNames e1 <> declaredNames e2+--     WithApp _ e es        -> declaredNames e <> declaredNames es+--     Lam _ b e             -> declaredNames b <> declaredNames e+--     AbsurdLam{}           -> mempty+--     ExtendedLam _ _ q cls -> singleton (WithKind FunName q) <> declaredNames cls+--     Pi _ tel e            -> declaredNames tel <> declaredNames e+--     Generalized s e       -> declaredNames e  -- NOT: fromList (map (WithKind GeneralizeName) $ Set.toList s) <> declaredNames e+--     Fun _ e1 e2           -> declaredNames e1 <> declaredNames e2+--     Set{}                 -> mempty+--     Prop{}                -> mempty+--     Let _ lbs e           -> declaredNames lbs <> declaredNames e+--     ETel{}                -> __IMPOSSIBLE__+--     Rec _ fields          -> declaredNames fields+--     RecUpdate _ e fs      -> declaredNames e <> declaredNames fs+--     ScopedExpr _ e        -> declaredNames e+--     Quote{}               -> mempty+--     QuoteTerm{}           -> mempty+--     Unquote{}             -> mempty+--     Tactic _ e xs         -> declaredNames e <> declaredNames xs+--     DontCare{}            -> mempty+--     PatternSyn{}          -> mempty+--     Macro{}               -> mempty++-- instance DeclaredNames LamBinding where+--   declaredNames DomainFree{}       = mempty+--   declaredNames (DomainFull binds) = declaredNames binds++-- instance DeclaredNames TypedBinding where+--   declaredNames (TBind _ t _ e) = declaredNames (t, e)+--   declaredNames (TLet _ lbs)    = declaredNames lbs++-- instance DeclaredNames LetBinding where+--   declaredNames (LetBind _ _ _ e1 e2)   = declaredNames e1 <> declaredNames e2+--   declaredNames (LetPatBind _ _ e)      = declaredNames e+--   declaredNames (LetApply _ _ app _ _)  = declaredNames app+--   declaredNames LetOpen{}               = mempty+--   declaredNames (LetDeclaredVariable _) = mempty++-- instance DeclaredNames ModuleApplication where+--   declaredNames (SectionApp bindss _ es) = declaredNames bindss <> declaredNames es+--   declaredNames RecordModuleInstance{}   = mempty

src/full/Agda/Syntax/Builtin.hs view

@@ -1,6 +1,8 @@ -- | This module defines the names of all BUILTINs. module Agda.Syntax.Builtin where +import Agda.Utils.List+ builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,   builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals,   builtinNatLess, builtinInteger, builtinIntegerPos, builtinIntegerNegSuc,@@ -9,6 +11,7 @@   builtinSigma,   builtinBool, builtinTrue, builtinFalse,   builtinList, builtinNil, builtinCons, builtinIO,+  builtinMaybe, builtinNothing, builtinJust,   builtinPath, builtinPathP, builtinInterval, builtinIZero, builtinIOne, builtinPartial, builtinPartialP,   builtinIMin, builtinIMax, builtinINeg,   builtinIsOne,  builtinItIsOne, builtinIsOne1, builtinIsOne2, builtinIsOneEmpty,@@ -26,16 +29,21 @@   builtinInf, builtinSharp, builtinFlat,   builtinEquality, builtinRefl, builtinRewrite, builtinLevelMax,   builtinLevel, builtinLevelZero, builtinLevelSuc,-  builtinSetOmega,+  builtinSet, builtinProp, builtinSetOmega, builtinStrictSet, builtinSSetOmega,+  builtinLockUniv,   builtinFromNat, builtinFromNeg, builtinFromString,   builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit,+  builtinAgdaSortProp, builtinAgdaSortPropLit, builtinAgdaSortInf,   builtinAgdaSortUnsupported,   builtinHiding, builtinHidden, builtinInstance, builtinVisible,-  builtinRelevance, builtinRelevant, builtinIrrelevant, builtinArg,+  builtinRelevance, builtinRelevant, builtinIrrelevant,+  builtinQuantity, builtinQuantity0, builtinQuantityω,+  builtinModality, builtinModalityConstructor,   builtinAssoc, builtinAssocLeft, builtinAssocRight, builtinAssocNon,   builtinPrecedence, builtinPrecRelated, builtinPrecUnrelated,   builtinFixity, builtinFixityFixity,-  builtinArgInfo, builtinArgArgInfo, builtinArgArg,+  builtinArgInfo, builtinArgArgInfo,+  builtinArg, builtinArgArg,   builtinAbs, builtinAbsAbs, builtinAgdaTerm,   builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,   builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi,@@ -58,11 +66,13 @@   builtinAgdaTCMGetContext, builtinAgdaTCMExtendContext, builtinAgdaTCMInContext,   builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDefineFun,   builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition,-  builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm,+  builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm, builtinAgdaTCMQuoteOmegaTerm,   builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit, builtinAgdaTCMIsMacro,-  builtinAgdaTCMWithNormalisation, builtinAgdaTCMDebugPrint,+  builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconsParams, builtinAgdaTCMDebugPrint,+  builtinAgdaTCMOnlyReduceDefs, builtinAgdaTCMDontReduceDefs,   builtinAgdaTCMNoConstraints,-  builtinAgdaTCMRunSpeculative+  builtinAgdaTCMRunSpeculative,+  builtinAgdaTCMExec   :: String  builtinNat                               = "NATURAL"@@ -91,6 +101,9 @@ builtinList                              = "LIST" builtinNil                               = "NIL" builtinCons                              = "CONS"+builtinMaybe                             = "MAYBE"+builtinNothing                           = "NOTHING"+builtinJust                              = "JUST" builtinIO                                = "IO" builtinId                                = "ID" builtinConId                             = "CONID"@@ -143,7 +156,12 @@ builtinLevel                             = "LEVEL" builtinLevelZero                         = "LEVELZERO" builtinLevelSuc                          = "LEVELSUC"+builtinSet                               = "TYPE"+builtinProp                              = "PROP" builtinSetOmega                          = "SETOMEGA"+builtinLockUniv                          = "primLockUniv"+builtinSSetOmega                         = "STRICTSETOMEGA"+builtinStrictSet                         = "STRICTSET" builtinFromNat                           = "FROMNAT" builtinFromNeg                           = "FROMNEG" builtinFromString                        = "FROMSTRING"@@ -151,6 +169,9 @@ builtinAgdaSort                          = "AGDASORT" builtinAgdaSortSet                       = "AGDASORTSET" builtinAgdaSortLit                       = "AGDASORTLIT"+builtinAgdaSortProp                      = "AGDASORTPROP"+builtinAgdaSortPropLit                   = "AGDASORTPROPLIT"+builtinAgdaSortInf                       = "AGDASORTINF" builtinAgdaSortUnsupported               = "AGDASORTUNSUPPORTED" builtinHiding                            = "HIDING" builtinHidden                            = "HIDDEN"@@ -159,6 +180,11 @@ builtinRelevance                         = "RELEVANCE" builtinRelevant                          = "RELEVANT" builtinIrrelevant                        = "IRRELEVANT"+builtinQuantity                          = "QUANTITY"+builtinQuantity0                         = "QUANTITY-0"+builtinQuantityω                         = "QUANTITY-ω"+builtinModality                          = "MODALITY"+builtinModalityConstructor               = "MODALITY-CONSTRUCTOR" builtinAssoc                             = "ASSOC" builtinAssocLeft                         = "ASSOCLEFT" builtinAssocRight                        = "ASSOCRIGHT"@@ -238,11 +264,16 @@ builtinAgdaTCMCommit                     = "AGDATCMCOMMIT" builtinAgdaTCMQuoteTerm                  = "AGDATCMQUOTETERM" builtinAgdaTCMUnquoteTerm                = "AGDATCMUNQUOTETERM"+builtinAgdaTCMQuoteOmegaTerm             = "AGDATCMQUOTEOMEGATERM" builtinAgdaTCMIsMacro                    = "AGDATCMISMACRO" builtinAgdaTCMWithNormalisation          = "AGDATCMWITHNORMALISATION"+builtinAgdaTCMWithReconsParams           = "AGDATCMWITHRECONSPARAMS" builtinAgdaTCMDebugPrint                 = "AGDATCMDEBUGPRINT"+builtinAgdaTCMOnlyReduceDefs             = "AGDATCMONLYREDUCEDEFS"+builtinAgdaTCMDontReduceDefs             = "AGDATCMDONTREDUCEDEFS" builtinAgdaTCMNoConstraints              = "AGDATCMNOCONSTRAINTS" builtinAgdaTCMRunSpeculative             = "AGDATCMRUNSPECULATIVE"+builtinAgdaTCMExec                       = "AGDATCMEXEC"  -- | Builtins that come without a definition in Agda syntax. --   These are giving names to Agda internal concepts which@@ -255,6 +286,9 @@ --   The type of @Type@ would be @Type : Level → Setω@ --   which is not valid Agda. +isBuiltinNoDef :: String -> Bool+isBuiltinNoDef = hasElem builtinsNoDef+ builtinsNoDef :: [String] builtinsNoDef =   sizeBuiltins ++@@ -266,7 +300,11 @@   , builtinSub   , builtinIZero   , builtinIOne+  , builtinSet+  , builtinProp   , builtinSetOmega+  , builtinStrictSet+  , builtinSSetOmega   ]  sizeBuiltins :: [String]

src/full/Agda/Syntax/Common.hs view

@@ -1,9 +1,4 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-} -- for type equality ~-{-# LANGUAGE UndecidableInstances       #-} -- for functional dependency: LensNamed name (Arg a)+{-# LANGUAGE CPP #-}  {-| Some common syntactic entities are defined in this module. -}@@ -13,13 +8,14 @@  import Control.DeepSeq import Control.Arrow ((&&&))+import Control.Applicative ((<|>), liftA2)  #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup hiding (Arg) #endif+import Data.Bifunctor import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString-import Data.Foldable (Foldable) import qualified Data.Foldable as Fold import Data.Function import Data.Hashable (Hashable(..))@@ -35,6 +31,8 @@  import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List1  ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Null import Agda.Utils.PartialOrd@@ -52,17 +50,19 @@  -- | Used to specify whether something should be delayed. data Delayed = Delayed | NotDelayed-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  instance KillRange Delayed where   killRange = id +instance NFData Delayed+ --------------------------------------------------------------------------- -- * File ---------------------------------------------------------------------------  data FileType = AgdaFileType | MdFileType | RstFileType | TexFileType | OrgFileType-  deriving (Data, Eq, Ord, Show)+  deriving (Data, Eq, Ord, Show, Generic)  instance Pretty FileType where   pretty = \case@@ -72,28 +72,109 @@     TexFileType  -> "LaTeX"     OrgFileType  -> "org-mode" +instance NFData FileType+ ---------------------------------------------------------------------------+-- * Record Directives+---------------------------------------------------------------------------++data RecordDirectives' a = RecordDirectives+  { recInductive   :: Maybe (Ranged Induction)+  , recHasEta      :: Maybe HasEta0+  , recPattern     :: Maybe Range+  , recConstructor :: Maybe a+  } deriving (Functor, Data, Show, Eq)++emptyRecordDirectives :: RecordDirectives' a+emptyRecordDirectives = RecordDirectives empty empty empty empty++instance HasRange a => HasRange (RecordDirectives' a) where+  getRange (RecordDirectives a b c d) = getRange (a,b,c,d)++instance KillRange a => KillRange (RecordDirectives' a) where+  killRange (RecordDirectives a b c d) = killRange4 RecordDirectives a b c d++instance NFData a => NFData (RecordDirectives' a) where+  rnf (RecordDirectives a b c d) = c `seq` rnf (a, b, d)++--------------------------------------------------------------------------- -- * Eta-equality --------------------------------------------------------------------------- -data HasEta = NoEta | YesEta-  deriving (Data, Show, Eq, Ord)+-- | Does a record come with eta-equality?+data HasEta' a+  = YesEta+  | NoEta a+  deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable) -instance HasRange HasEta where+instance HasRange a => HasRange (HasEta' a) where+  getRange = foldMap getRange++instance KillRange a => KillRange (HasEta' a) where+  killRange = fmap killRange++instance NFData a => NFData (HasEta' a) where+  rnf YesEta    = ()+  rnf (NoEta p) = rnf p++-- | Pattern and copattern matching is allowed in the presence of eta.+--+--   In the absence of eta, we have to choose whether we want to allow+--   matching on the constructor or copattern matching with the projections.+--   Having both leads to breakage of subject reduction (issue #4560).++type HasEta  = HasEta' PatternOrCopattern+type HasEta0 = HasEta' ()++-- | For a record without eta, which type of matching do we allow?+data PatternOrCopattern+  = PatternMatching+      -- ^ Can match on the record constructor.+  | CopatternMatching+      -- ^ Can copattern match using the projections. (Default.)+  deriving (Data, Show, Eq, Ord, Enum, Bounded)++instance NFData PatternOrCopattern where+  rnf PatternMatching   = ()+  rnf CopatternMatching = ()++instance HasRange PatternOrCopattern where   getRange _ = noRange -instance KillRange HasEta where+instance KillRange PatternOrCopattern where   killRange = id -instance NFData HasEta where-  rnf NoEta  = ()-  rnf YesEta = ()+-- | Can we pattern match on the record constructor?+class PatternMatchingAllowed a where+  patternMatchingAllowed :: a -> Bool +instance PatternMatchingAllowed PatternOrCopattern where+  patternMatchingAllowed = (== PatternMatching)++instance PatternMatchingAllowed HasEta where+  patternMatchingAllowed = \case+    YesEta -> True+    NoEta p -> patternMatchingAllowed p+++-- | Can we construct a record by copattern matching?+class CopatternMatchingAllowed a where+  copatternMatchingAllowed :: a -> Bool++instance CopatternMatchingAllowed PatternOrCopattern where+  copatternMatchingAllowed = (== CopatternMatching)++instance CopatternMatchingAllowed HasEta where+  copatternMatchingAllowed = \case+    YesEta -> True+    NoEta p -> copatternMatchingAllowed p+ --------------------------------------------------------------------------- -- * Induction --------------------------------------------------------------------------- -data Induction = Inductive | CoInductive+-- | @Inductive < Coinductive@+data Induction = Inductive | CoInductive  -- Keep in this order!   deriving (Data, Eq, Ord, Show)  instance Pretty Induction where@@ -110,6 +191,9 @@   rnf Inductive   = ()   rnf CoInductive = () +instance PatternMatchingAllowed Induction where+  patternMatchingAllowed = (== Inductive)+ --------------------------------------------------------------------------- -- * Hiding ---------------------------------------------------------------------------@@ -150,6 +234,9 @@   mempty = NotHidden   mappend = (<>) +instance HasRange Hiding where+  getRange _ = noRange+ instance KillRange Hiding where   killRange = id @@ -215,6 +302,11 @@   setHiding h (WithHiding _ a) = WithHiding h a   mapHiding f (WithHiding h a) = WithHiding (f h) a +instance LensHiding a => LensHiding (Named nm a) where+  getHiding = getHiding . namedThing+  setHiding = fmap . setHiding+  mapHiding = fmap . mapHiding+ -- | Monoidal composition of 'Hiding' information in some data. mergeHiding :: LensHiding a => WithHiding a -> a mergeHiding (WithHiding h a) = mapHiding (mappend h) a@@ -270,6 +362,20 @@ -- * Modalities --------------------------------------------------------------------------- +-- | Type wrapper to indicate additive monoid/semigroup context.+newtype UnderAddition t = UnderAddition t deriving (Show, Functor, Eq, Ord, PartialOrd)++instance Applicative UnderAddition where+  pure = UnderAddition+  (<*>) (UnderAddition f) (UnderAddition a) = pure (f a)++-- | Type wrapper to indicate composition or multiplicative monoid/semigroup context.+newtype UnderComposition t = UnderComposition t deriving (Show, Functor, Eq, Ord, PartialOrd)++instance Applicative UnderComposition where+  pure = UnderComposition+  (<*>) (UnderComposition f) (UnderComposition a) = pure (f a)+ -- | We have a tuple of modalities, which might not be fully orthogonal. --   For instance, irrelevant stuff is also run-time irrelevant. data Modality = Modality@@ -286,28 +392,37 @@       --   Currently only the comonad is implemented.   } deriving (Data, Eq, Ord, Show, Generic) -defaultModality :: Modality-defaultModality = Modality defaultRelevance defaultQuantity defaultCohesion+-- | Dominance ordering.+instance PartialOrd Modality where+  comparable (Modality r q c) (Modality r' q' c') = comparable (r, (q, c)) (r', (q', c'))  -- | Pointwise composition.-instance Semigroup Modality where-  Modality r q c <> Modality r' q' c' = Modality (r <> r') (q <> q') (c <> c')+instance Semigroup (UnderComposition Modality) where+  (<>) = liftA2 composeModality --- | Pointwise unit.-instance Monoid Modality where-  mempty = Modality mempty mempty mempty+-- | Pointwise composition unit.+instance Monoid (UnderComposition Modality) where+  mempty  = pure unitModality   mappend = (<>) --- | Dominance ordering.-instance PartialOrd Modality where-  comparable (Modality r q c) (Modality r' q' c') = comparable (r, (q, c)) (r', (q', c'))+instance POSemigroup (UnderComposition Modality) where+instance POMonoid (UnderComposition Modality) where -instance POSemigroup Modality where-instance POMonoid Modality where+instance LeftClosedPOMonoid (UnderComposition Modality) where+  inverseCompose = liftA2 inverseComposeModality -instance LeftClosedPOMonoid Modality where-  inverseCompose = inverseComposeModality+-- | Pointwise addition.+instance Semigroup (UnderAddition Modality) where+  (<>) = liftA2 addModality +-- | Pointwise additive unit.+instance Monoid (UnderAddition Modality) where+  mempty  = pure zeroModality+  mappend = (<>)++instance POSemigroup (UnderAddition Modality) where+instance POMonoid (UnderAddition Modality) where+ -- | @m `moreUsableModality` m'@ means that an @m@ can be used --   where ever an @m'@ is required. @@ -320,7 +435,10 @@  -- | Multiplicative monoid (standard monoid). composeModality :: Modality -> Modality -> Modality-composeModality = (<>)+composeModality (Modality r q c) (Modality r' q' c') =+    Modality (r `composeRelevance` r')+             (q `composeQuantity` q')+             (c `composeCohesion` c')  -- | Compose with modality flag from the left. --   This function is e.g. used to update the modality information@@ -341,20 +459,36 @@  -- | Left division by a 'Modality'. --   Used e.g. to modify context when going into a @m@ argument.-inverseApplyModality :: LensModality a => Modality -> a -> a-inverseApplyModality m = mapModality (m `inverseComposeModality`)+--+-- Note that this function does not change quantities.+inverseApplyModalityButNotQuantity :: LensModality a => Modality -> a -> a+inverseApplyModalityButNotQuantity m =+  mapModality (m' `inverseComposeModality`)+  where+  m' = setQuantity (Quantity1 Q1Inferred) m  -- | 'Modality' forms a pointwise additive monoid. addModality :: Modality -> Modality -> Modality addModality (Modality r q c) (Modality r' q' c') = Modality (addRelevance r r') (addQuantity q q') (addCohesion c c') +-- | Identity under addition zeroModality :: Modality zeroModality = Modality zeroRelevance zeroQuantity zeroCohesion +-- | Identity under composition+unitModality :: Modality+unitModality = Modality unitRelevance unitQuantity unitCohesion+ -- | Absorptive element under addition. topModality :: Modality topModality = Modality topRelevance topQuantity topCohesion +-- | The default Modality+--   Beware that this is neither the additive unit nor the unit under+--   composition, because the default quantity is ω.+defaultModality :: Modality+defaultModality = Modality defaultRelevance defaultQuantity defaultCohesion+ -- | Equality ignoring origin.  sameModality :: (LensModality a, LensModality b) => a -> b -> Bool@@ -363,8 +497,11 @@  -- boilerplate instances +instance HasRange Modality where+  getRange (Modality r q c) = getRange (r, q, c)+ instance KillRange Modality where-  killRange = id+  killRange (Modality r q c) = killRange3 Modality r q c  instance NFData Modality where @@ -616,9 +753,6 @@   deriving (Data, Show, Generic, Eq, Ord)     -- @Ord@ instance in case @Quantity@ is used in keys for maps etc. -defaultQuantity :: Quantity-defaultQuantity = topQuantity- -- | Equality ignoring origin.  sameQuantity :: Quantity -> Quantity -> Bool@@ -635,19 +769,31 @@ -- -- Right-biased for origin. ---instance Semigroup Quantity where-  Quantity1{} <> q = q           -- right-bias!-  q <> Quantity1{} = q-  _ <> Quantity0 o = Quantity0 o -- right-bias!-  Quantity0 o <> _ = Quantity0 o-  _omega <> qomega = qomega      -- right-bias!+instance Semigroup (UnderComposition Quantity) where+  (<>) = liftA2 composeQuantity  -- | In the absense of finite quantities besides 0, ω is the unit. --   Otherwise, 1 is the unit.-instance Monoid Quantity where-  mempty  = Quantity1 mempty+instance Monoid (UnderComposition Quantity) where+  mempty  = pure unitQuantity   mappend = (<>) +instance POSemigroup (UnderComposition Quantity) where+instance POMonoid (UnderComposition Quantity) where++instance LeftClosedPOMonoid (UnderComposition Quantity) where+  inverseCompose = liftA2 inverseComposeQuantity++instance Semigroup (UnderAddition Quantity) where+  (<>) = liftA2 addQuantity++instance Monoid (UnderAddition Quantity) where+  mempty  = pure zeroQuantity+  mappend = (<>)++instance POSemigroup (UnderAddition Quantity) where+instance POMonoid (UnderAddition Quantity) where+ -- | Note that the order is @ω ≤ 0,1@, more options is smaller. instance PartialOrd Quantity where   comparable = curry $ \case@@ -658,12 +804,6 @@     -- others are uncomparable     _ -> POAny -instance POSemigroup Quantity where-instance POMonoid Quantity where--instance LeftClosedPOMonoid Quantity where-  inverseCompose = inverseComposeQuantity- -- | 'Quantity' forms an additive monoid with zero Quantity0. addQuantity :: Quantity -> Quantity -> Quantity addQuantity = curry $ \case@@ -676,9 +816,20 @@   -- 1 + 1 = ω   (Quantity1 _, Quantity1 _) -> topQuantity +-- | Identity element under addition zeroQuantity :: Quantity zeroQuantity = Quantity0 mempty +-- | Absorptive element!+--   This differs from Relevance and Cohesion whose default+--   is the multiplicative unit.+defaultQuantity :: Quantity+defaultQuantity = topQuantity++-- | Identity element under composition+unitQuantity :: Quantity+unitQuantity = Quantityω mempty+ -- | Absorptive element is ω. topQuantity :: Quantity topQuantity = Quantityω mempty@@ -689,8 +840,22 @@ moreQuantity :: Quantity -> Quantity -> Bool moreQuantity m m' = related m POLE m' +-- | Composition of quantities (multiplication).+--+-- 'Quantity0' is dominant.+-- 'Quantity1' is neutral.+--+-- Right-biased for origin.+-- composeQuantity :: Quantity -> Quantity -> Quantity-composeQuantity = (<>)+composeQuantity = curry $ \case+  (Quantity1 o, Quantity1 o') -> Quantity1 (o <> o')+  (Quantity1{}, q           ) -> q+  (q          , Quantity1{} ) -> q+  (Quantity0 o, Quantity0 o') -> Quantity0 (o <> o')+  (_          , Quantity0 o ) -> Quantity0 o+  (Quantity0 o, _           ) -> Quantity0 o+  (Quantityω o, Quantityω o') -> Quantityω (o <> o')  -- | Compose with quantity flag from the left. --   This function is e.g. used to update the quantity information@@ -797,6 +962,63 @@   rnf (Quantity1 o) = rnf o   rnf (Quantityω o) = rnf o +-- ** Erased.++-- | A special case of 'Quantity': erased or not.++data Erased+  = Erased Q0Origin+  | NotErased QωOrigin+  deriving (Data, Show, Eq, Generic)++-- | The default value of type 'Erased': not erased.++defaultErased :: Erased+defaultErased = NotErased QωInferred++-- 'Erased' can be converted into 'Quantity'.++asQuantity :: Erased -> Quantity+asQuantity (Erased    o) = Quantity0 o+asQuantity (NotErased o) = Quantityω o++-- | Equality ignoring origin.++sameErased :: Erased -> Erased -> Bool+sameErased = sameQuantity `on` asQuantity++-- | Is the value \"erased\"?++isErased :: Erased -> Bool+isErased = hasQuantity0 . asQuantity++instance NFData Erased++instance HasRange Erased where+  getRange = getRange . asQuantity++instance KillRange Erased where+  killRange = \case+    Erased o    -> Erased $ killRange o+    NotErased o -> NotErased $ killRange o++-- | Composition of values of type 'Erased'.+--+-- 'Erased' is dominant.+-- 'NotErased' is neutral.+--+-- Right-biased for the origin.++composeErased :: Erased -> Erased -> Erased+composeErased = curry $ \case+  (Erased o,    Erased o')    -> Erased (o <> o')+  (NotErased _, Erased o)     -> Erased o+  (Erased o,    NotErased _)  -> Erased o+  (NotErased o, NotErased o') -> NotErased (o <> o')++instance Semigroup (UnderComposition Erased) where+  (<>) = liftA2 composeErased+ --------------------------------------------------------------------------- -- * Relevance ---------------------------------------------------------------------------@@ -814,9 +1036,6 @@ allRelevances :: [Relevance] allRelevances = [minBound..maxBound] -defaultRelevance :: Relevance-defaultRelevance = Relevant- instance HasRange Relevance where   getRange _ = noRange @@ -892,10 +1111,7 @@  -- | @usableRelevance rel == False@ iff we cannot use a variable of @rel@. usableRelevance :: LensRelevance a => a -> Bool-usableRelevance a = case getRelevance a of-  Irrelevant -> False-  NonStrict  -> False-  Relevant   -> True+usableRelevance = isRelevant  -- | 'Relevance' composition. --   'Irrelevant' is dominant, 'Relevant' is neutral.@@ -935,20 +1151,30 @@ inverseApplyRelevance rel = mapRelevance (rel `inverseComposeRelevance`)  -- | 'Relevance' forms a semigroup under composition.-instance Semigroup Relevance where-  (<>) = composeRelevance+instance Semigroup (UnderComposition Relevance) where+  (<>) = liftA2 composeRelevance --- | 'Relevant' is the unit.-instance Monoid Relevance where-  mempty  = Relevant+-- | 'Relevant' is the unit under composition.+instance Monoid (UnderComposition Relevance) where+  mempty  = pure unitRelevance   mappend = (<>) -instance POSemigroup Relevance where-instance POMonoid Relevance where+instance POSemigroup (UnderComposition Relevance) where+instance POMonoid (UnderComposition Relevance) where -instance LeftClosedPOMonoid Relevance where-  inverseCompose = inverseComposeRelevance+instance LeftClosedPOMonoid (UnderComposition Relevance) where+  inverseCompose = liftA2 inverseComposeRelevance +instance Semigroup (UnderAddition Relevance) where+  (<>) = liftA2 addRelevance++instance Monoid (UnderAddition Relevance) where+  mempty  = pure zeroRelevance+  mappend = (<>)++instance POSemigroup (UnderAddition Relevance) where+instance POMonoid (UnderAddition Relevance) where+ -- | Combine inferred 'Relevance'. --   The unit is 'Irrelevant'. addRelevance :: Relevance -> Relevance -> Relevance@@ -958,10 +1184,18 @@ zeroRelevance :: Relevance zeroRelevance = Irrelevant +-- | Identity element under composition+unitRelevance :: Relevance+unitRelevance = Relevant+ -- | Absorptive element under addition. topRelevance :: Relevance topRelevance = Relevant +-- | Default Relevance is the identity element under composition+defaultRelevance :: Relevance+defaultRelevance = unitRelevance+ -- | Irrelevant function arguments may appear non-strictly in the codomain type. irrToNonStrict :: Relevance -> Relevance irrToNonStrict Irrelevant = NonStrict@@ -976,7 +1210,95 @@ nonStrictToIrr NonStrict = Irrelevant nonStrictToIrr rel       = rel + ---------------------------------------------------------------------------+-- * Annotations+---------------------------------------------------------------------------++-- | We have a tuple of annotations, which might not be fully orthogonal.+data Annotation = Annotation+  { annLock :: Lock+    -- ^ Fitch-style dependent right adjoints.+    --   See Modal Dependent Type Theory and Dependent Right Adjoints, arXiv:1804.05236.+  } deriving (Data, Eq, Ord, Show, Generic)++instance HasRange Annotation where+  getRange _ = noRange++instance KillRange Annotation where+  killRange = id++defaultAnnotation :: Annotation+defaultAnnotation = Annotation defaultLock++instance NFData Annotation where+  rnf (Annotation l) = rnf l++class LensAnnotation a where++  getAnnotation :: a -> Annotation++  setAnnotation :: Annotation -> a -> a++  mapAnnotation :: (Annotation -> Annotation) -> a -> a+  mapAnnotation f a = setAnnotation (f $ getAnnotation a) a++  default getAnnotation :: LensArgInfo a => a -> Annotation+  getAnnotation = argInfoAnnotation . getArgInfo++  default setAnnotation :: LensArgInfo a => Annotation -> a -> a+  setAnnotation a = mapArgInfo $ \ ai -> ai { argInfoAnnotation = a }++instance LensAnnotation Annotation where+  getAnnotation = id+  setAnnotation = const+  mapAnnotation = id++instance LensAnnotation (Arg t) where+  getAnnotation = getAnnotation . getArgInfo+  setAnnotation = mapArgInfo . setAnnotation+++---------------------------------------------------------------------------+-- * Locks+---------------------------------------------------------------------------++data Lock = IsNotLock+          | IsLock -- ^ In the future there might be different kinds of them.+                   --   For now we assume lock weakening.+  deriving (Data, Show, Generic, Eq, Enum, Bounded, Ord)++defaultLock :: Lock+defaultLock = IsNotLock++instance NFData Lock where+  rnf IsNotLock = ()+  rnf IsLock    = ()++class LensLock a where++  getLock :: a -> Lock++  setLock :: Lock -> a -> a+  setLock = mapLock . const++  mapLock :: (Lock -> Lock) -> a -> a+  mapLock f a = setLock (f $ getLock a) a++instance LensLock Lock where+  getLock = id+  setLock = const+  mapLock = id++instance LensLock ArgInfo where+  getLock = annLock . argInfoAnnotation+  setLock l info = info { argInfoAnnotation = Annotation l }++instance LensLock (Arg t) where+  getLock = getLock . getArgInfo+  setLock = mapArgInfo . setLock++--------------------------------------------------------------------------- -- * Cohesion --------------------------------------------------------------------------- @@ -993,9 +1315,6 @@ allCohesions :: [Cohesion] allCohesions = [minBound..maxBound] -defaultCohesion :: Cohesion-defaultCohesion = Continuous- instance HasRange Cohesion where   getRange _ = noRange @@ -1103,20 +1422,32 @@ inverseApplyCohesion rel = mapCohesion (rel `inverseComposeCohesion`)  -- | 'Cohesion' forms a semigroup under composition.-instance Semigroup Cohesion where-  (<>) = composeCohesion+instance Semigroup (UnderComposition Cohesion) where+  (<>) = liftA2 composeCohesion --- | 'Continous' is the unit.-instance Monoid Cohesion where-  mempty  = Continuous+-- | 'Continous' is the multiplicative unit.+instance Monoid (UnderComposition Cohesion) where+  mempty  = pure unitCohesion   mappend = (<>) -instance POSemigroup Cohesion where-instance POMonoid Cohesion where+instance POSemigroup (UnderComposition Cohesion) where+instance POMonoid (UnderComposition Cohesion) where -instance LeftClosedPOMonoid Cohesion where-  inverseCompose = inverseComposeCohesion+instance LeftClosedPOMonoid (UnderComposition Cohesion) where+  inverseCompose = liftA2 inverseComposeCohesion +-- | 'Cohesion' forms a semigroup under addition.+instance Semigroup (UnderAddition Cohesion) where+  (<>) = liftA2 addCohesion++-- | 'Squash' is the additive unit.+instance Monoid (UnderAddition Cohesion) where+  mempty  = pure zeroCohesion+  mappend = (<>)++instance POSemigroup (UnderAddition Cohesion) where+instance POMonoid (UnderAddition Cohesion) where+ -- | Combine inferred 'Cohesion'. --   The unit is 'Squash'. addCohesion :: Cohesion -> Cohesion -> Cohesion@@ -1126,10 +1457,18 @@ zeroCohesion :: Cohesion zeroCohesion = Squash +-- | Identity under composition+unitCohesion :: Cohesion+unitCohesion = Continuous+ -- | Absorptive element under addition. topCohesion :: Cohesion topCohesion = Flat +-- | Default Cohesion is the identity element under composition+defaultCohesion :: Cohesion+defaultCohesion = unitCohesion+ --------------------------------------------------------------------------- -- * Origin of arguments (user-written, inserted or reflected) ---------------------------------------------------------------------------@@ -1143,6 +1482,9 @@   | Substitution -- ^ Named application produced to represent a substitution. E.g. "?0 (x = n)" instead of "?0 n"   deriving (Data, Show, Eq, Ord) +instance HasRange Origin where+  getRange _ = noRange+ instance KillRange Origin where   killRange = id @@ -1222,6 +1564,9 @@   mempty  = KnownFVs IntSet.empty   mappend = (<>) +instance KillRange FreeVariables where+  killRange = id+ instance NFData FreeVariables where   rnf UnknownFVs    = ()   rnf (KnownFVs fv) = rnf fv@@ -1277,10 +1622,16 @@   , argInfoModality      :: Modality   , argInfoOrigin        :: Origin   , argInfoFreeVariables :: FreeVariables+  , argInfoAnnotation    :: Annotation+    -- ^ Sometimes we want a different kind of binder/pi-type, without it+    --   supporting any of the @Modality@ interface.   } deriving (Data, Eq, Ord, Show) +instance HasRange ArgInfo where+  getRange (ArgInfo h m o _fv a) = getRange (h, m, o, a)+ instance KillRange ArgInfo where-  killRange i = i -- There are no ranges in ArgInfo's+  killRange (ArgInfo h m o fv a) = killRange5 ArgInfo h m o fv a  class LensArgInfo a where   getArgInfo :: a -> ArgInfo@@ -1295,7 +1646,7 @@   mapArgInfo = id  instance NFData ArgInfo where-  rnf (ArgInfo a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  rnf (ArgInfo a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e  instance LensHiding ArgInfo where   getHiding = argInfoHiding@@ -1317,6 +1668,11 @@   setFreeVariables o ai = ai { argInfoFreeVariables = o }   mapFreeVariables f ai = ai { argInfoFreeVariables = f (argInfoFreeVariables ai) } +instance LensAnnotation ArgInfo where+  getAnnotation = argInfoAnnotation+  setAnnotation m ai = ai { argInfoAnnotation = m }+  mapAnnotation f ai = ai { argInfoAnnotation = f (argInfoAnnotation ai) }+ -- inherited instances  instance LensRelevance ArgInfo where@@ -1340,6 +1696,7 @@   , argInfoModality      = defaultModality   , argInfoOrigin        = UserWritten   , argInfoFreeVariables = UnknownFVs+  , argInfoAnnotation    = defaultAnnotation   }  -- Accessing through ArgInfo@@ -1585,6 +1942,11 @@ unnamed :: a -> Named name a unnamed = Named Nothing +isUnnamed :: Named name a -> Maybe a+isUnnamed = \case+  Named Nothing a -> Just a+  Named Just{}  a -> Nothing+ named :: name -> a -> Named name a named = Named . Just @@ -1592,38 +1954,43 @@ userNamed = Named . Just . WithOrigin UserWritten  -- | Accessor/editor for the 'nameOf' component.-class LensNamed name a | a -> name where-  lensNamed :: Lens' (Maybe name) a+class LensNamed a where+  -- | The type of the name+  type NameOf a+  lensNamed :: Lens' (Maybe (NameOf a)) a    -- Lenses lift through decorations:-  default lensNamed :: (Decoration f, LensNamed name b, f b ~ a) => Lens' (Maybe name) a+  default lensNamed :: (Decoration f, LensNamed b, NameOf b ~ NameOf a, f b ~ a) => Lens' (Maybe (NameOf a)) a   lensNamed = traverseF . lensNamed -instance LensNamed name a => LensNamed name (Arg a) where+instance LensNamed a => LensNamed (Arg a) where+  type NameOf (Arg a) = NameOf a -instance LensNamed name (Maybe name) where+instance LensNamed (Maybe a) where+  type NameOf (Maybe a) = a   lensNamed = id -instance LensNamed name (Named name a) where+instance LensNamed (Named name a) where+  type NameOf (Named name a) = name+   lensNamed f (Named mn a) = f mn <&> \ mn' -> Named mn' a -getNameOf :: LensNamed name a => a -> Maybe name+getNameOf :: LensNamed a => a -> Maybe (NameOf a) getNameOf a = a ^. lensNamed -setNameOf :: LensNamed name a => Maybe name -> a -> a+setNameOf :: LensNamed a => Maybe (NameOf a) -> a -> a setNameOf = set lensNamed -mapNameOf :: LensNamed name a => (Maybe name -> Maybe name) -> a -> a+mapNameOf :: LensNamed a => (Maybe (NameOf a) -> Maybe (NameOf a)) -> a -> a mapNameOf = over lensNamed--bareNameOf :: LensNamed NamedName a => a -> Maybe ArgName+bareNameOf :: (LensNamed a, NameOf a ~ NamedName) => a -> Maybe ArgName bareNameOf a = rangedThing . woThing <$> getNameOf a -bareNameWithDefault :: LensNamed NamedName a => ArgName -> a -> ArgName+bareNameWithDefault :: (LensNamed a, NameOf a ~ NamedName) => ArgName -> a -> ArgName bareNameWithDefault x a = maybe x (rangedThing . woThing) $ getNameOf a  -- | Equality of argument names of things modulo 'Range' and 'Origin'.-namedSame :: (LensNamed NamedName a, LensNamed NamedName b) => a -> b -> Bool+namedSame :: (LensNamed a, LensNamed b, NameOf a ~ NamedName, NameOf b ~ NamedName) => a -> b -> Bool namedSame a b = case (getNameOf a, getNameOf b) of   (Nothing, Nothing) -> True   (Just x , Just y ) -> sameName x y@@ -1640,8 +2007,8 @@ --   @@ -- fittingNamedArg-  :: ( LensNamed NamedName arg, LensHiding arg-     , LensNamed NamedName dom, LensHiding dom )+  :: ( LensNamed arg, NameOf arg ~ NamedName, LensHiding arg+     , LensNamed dom, NameOf dom ~ NamedName, LensHiding dom )   => arg -> dom -> Maybe Bool fittingNamedArg arg dom     | not $ sameHiding arg dom = no@@ -1735,17 +2102,17 @@ unranged :: a -> Ranged a unranged = Ranged noRange +-- | Ignores range. instance Pretty a => Pretty (Ranged a) where   pretty = pretty . rangedThing --- instance Show a => Show (Ranged a) where---   show = show . rangedThing-+-- | Ignores range. instance Eq a => Eq (Ranged a) where-  Ranged _ x == Ranged _ y = x == y+  (==) = (==) `on` rangedThing +-- | Ignores range. instance Ord a => Ord (Ranged a) where-  compare (Ranged _ x) (Ranged _ y) = compare x y+  compare = compare `on` rangedThing  instance HasRange (Ranged a) where   getRange = rangeOf@@ -1787,8 +2154,10 @@   | ConOCon     -- ^ User wrote a constructor (pattern).   | ConORec     -- ^ User wrote a record (pattern).   | ConOSplit   -- ^ Generated by interactive case splitting.-  deriving (Data, Show, Eq, Ord, Enum, Bounded)+  deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic) +instance NFData ConOrigin+ instance KillRange ConOrigin where   killRange = id @@ -1802,14 +2171,13 @@   = ProjPrefix    -- ^ User wrote a prefix projection.   | ProjPostfix   -- ^ User wrote a postfix projection.   | ProjSystem    -- ^ Projection was generated by the system.-  deriving (Data, Show, Eq, Ord, Enum, Bounded)+  deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic) +instance NFData ProjOrigin+ instance KillRange ProjOrigin where   killRange = id -data DataOrRecord = IsData | IsRecord-  deriving (Data, Eq, Ord, Show)- --------------------------------------------------------------------------- -- * Infixity, access, abstract, etc. ---------------------------------------------------------------------------@@ -1847,7 +2215,7 @@  -- | Abstract or concrete. data IsAbstract = AbstractDef | ConcreteDef-    deriving (Data, Show, Eq, Ord)+    deriving (Data, Show, Eq, Ord, Generic)  -- | Semigroup computes if any of several is an 'AbstractDef'. instance Semigroup IsAbstract where@@ -1862,6 +2230,8 @@ instance KillRange IsAbstract where   killRange = id +instance NFData IsAbstract+ class LensIsAbstract a where   lensIsAbstract :: Lens' IsAbstract a @@ -1907,18 +2277,26 @@  -- | Is this a macro definition? data IsMacro = MacroDef | NotMacroDef-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  instance KillRange IsMacro where killRange = id instance HasRange  IsMacro where getRange _ = noRange +instance NFData IsMacro+ --------------------------------------------------------------------------- -- * NameId --------------------------------------------------------------------------- +newtype ModuleNameHash = ModuleNameHash Word64+  deriving (Eq, Ord, Show, Data)++noModuleNameHash :: ModuleNameHash+noModuleNameHash = ModuleNameHash 0+ -- | The unique identifier of a name. Second argument is the top-level module --   identifier.-data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash     deriving (Eq, Ord, Data, Generic, Show)  instance KillRange NameId where@@ -1936,9 +2314,12 @@ instance NFData NameId where   rnf (NameId _ _) = () +instance NFData ModuleNameHash where+  rnf _ = ()+ instance Hashable NameId where   {-# INLINE hashWithSalt #-}-  hashWithSalt salt (NameId n m) = hashWithSalt salt (n, m)+  hashWithSalt salt (NameId n (ModuleNameHash m)) = hashWithSalt salt (n, m)  --------------------------------------------------------------------------- -- * Meta variables@@ -1964,6 +2345,19 @@  newtype Constr a = Constr a +-----------------------------------------------------------------------------+-- * Problems+-----------------------------------------------------------------------------++-- | A "problem" consists of a set of constraints and the same constraint can be part of multiple+--   problems.+newtype ProblemId = ProblemId Nat+  deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData)++-- This particular Show instance is ok because of the Num instance.+instance Show   ProblemId where show   (ProblemId n) = show n+instance Pretty ProblemId where pretty (ProblemId n) = pretty n+ ------------------------------------------------------------------------ -- * Placeholders (used to parse sections) ------------------------------------------------------------------------@@ -2021,6 +2415,7 @@              , Real              , Enum              , Data+             , NFData              )  instance Pretty InteractionId where@@ -2048,6 +2443,10 @@   null Related{} = False   empty = Unrelated +instance NFData FixityLevel where+  rnf Unrelated   = ()+  rnf (Related _) = ()+ -- | Associativity.  data Associativity = NonAssoc | LeftAssoc | RightAssoc@@ -2154,12 +2553,15 @@ data ImportDirective' n m = ImportDirective   { importDirRange :: Range   , using          :: Using' n m-  , hiding         :: [ImportedName' n m]-  , impRenaming    :: [Renaming' n m]+  , hiding         :: HidingDirective' n m+  , impRenaming    :: RenamingDirective' n m   , publicOpen     :: Maybe Range -- ^ Only for @open@. Exports the opened names from the current module.   }   deriving (Data, Eq) +type HidingDirective'   n m = [ImportedName' n m]+type RenamingDirective' n m = [Renaming' n m]+ -- | @null@ for import directives holds when everything is imported unchanged --   (no names are hidden or renamed). instance Null (ImportDirective' n m) where@@ -2168,6 +2570,19 @@     _ -> False   empty = defaultImportDir +instance (HasRange n, HasRange m) => Semigroup (ImportDirective' n m) where+  i1 <> i2 = ImportDirective+    { importDirRange = fuseRange i1 i2+    , using          = using i1 <> using i2+    , hiding         = hiding i1 ++ hiding i2+    , impRenaming    = impRenaming i1 ++ impRenaming i2+    , publicOpen     = publicOpen i1 <|> publicOpen i2+    }++instance (HasRange n, HasRange m) => Monoid (ImportDirective' n m) where+  mempty  = empty+  mappend = (<>)+ -- | Default is directive is @private@ (use everything, but do not export). defaultImportDir :: ImportDirective' n m defaultImportDir = ImportDirective noRange UseEverything [] [] Nothing@@ -2207,10 +2622,21 @@   | ImportedName    n  -- ^ Imported name of type @n@.   deriving (Data, Eq, Ord, Show) +fromImportedName :: ImportedName' a a -> a+fromImportedName = \case+  ImportedModule x -> x+  ImportedName   x -> x+ setImportedName :: ImportedName' a a -> a -> ImportedName' a a setImportedName (ImportedName   x) y = ImportedName   y setImportedName (ImportedModule x) y = ImportedModule y +-- | Like 'partitionEithers'.+partitionImportedNames :: [ImportedName' n m] -> ([n], [m])+partitionImportedNames = flip foldr ([], []) $ \case+  ImportedName   n -> first  (n:)+  ImportedModule m -> second (m:)+ -- -- Defined in Concrete.Pretty -- instance (Pretty n, Pretty m) => Pretty (ImportedName' n m) where --   pretty (ImportedModule x) = "module" <+> pretty x@@ -2320,7 +2746,7 @@  -- | Positivity check? (Default = True). data PositivityCheck = YesPositivityCheck | NoPositivityCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data)+  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)  instance KillRange PositivityCheck where   killRange = id@@ -2335,24 +2761,28 @@   mempty  = YesPositivityCheck   mappend = (<>) +instance NFData PositivityCheck+ ----------------------------------------------------------------------------- -- * Universe checking -----------------------------------------------------------------------------  -- | Universe check? (Default is yes). data UniverseCheck = YesUniverseCheck | NoUniverseCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data)+  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)  instance KillRange UniverseCheck where   killRange = id +instance NFData UniverseCheck+ ----------------------------------------------------------------------------- -- * Universe checking -----------------------------------------------------------------------------  -- | Coverage check? (Default is yes). data CoverageCheck = YesCoverageCheck | NoCoverageCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data)+  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)  instance KillRange CoverageCheck where   killRange = id@@ -2367,6 +2797,8 @@   mempty  = YesCoverageCheck   mappend = (<>) +instance NFData CoverageCheck+ ----------------------------------------------------------------------------- -- * Rewrite Directives on the LHS -----------------------------------------------------------------------------@@ -2374,30 +2806,37 @@ -- | @RewriteEqn' qn p e@ represents the @rewrite@ and irrefutable @with@ --   clauses of the LHS. --   @qn@ stands for the QName of the auxiliary function generated to implement the feature---   @p@ is the type of patterns---   @e@ is the type of expressions+--   @nm@ is the type of names for pattern variables+--   @p@  is the type of patterns+--   @e@  is the type of expressions -data RewriteEqn' qn p e-  = Rewrite [(qn, e)]  -- ^ @rewrite e@-  | Invert qn [(p, e)] -- ^ @with p <- e@+data RewriteEqn' qn nm p e+  = Rewrite (List1 (qn, e))             -- ^ @rewrite e@+  | Invert qn (List1 (Named nm (p, e))) -- ^ @with p <- e in eq@   deriving (Data, Eq, Show, Functor, Foldable, Traversable) -instance (NFData qn, NFData p, NFData e) => NFData (RewriteEqn' qn p e) where+instance (NFData qn, NFData nm, NFData p, NFData e) => NFData (RewriteEqn' qn nm p e) where   rnf = \case     Rewrite es    -> rnf es     Invert qn pes -> rnf (qn, pes) -instance (Pretty p, Pretty e) => Pretty (RewriteEqn' qn p e) where+instance (Pretty nm, Pretty p, Pretty e) => Pretty (RewriteEqn' qn nm p e) where   pretty = \case-    Rewrite es   -> prefixedThings (text "rewrite") (pretty . snd <$> es)-    Invert _ pes -> prefixedThings (text "invert") (pes <&> \ (p, e) -> pretty p <+> "<-" <+> pretty e)+    Rewrite es   -> prefixedThings (text "rewrite") $ List1.toList (pretty . snd <$> es)+    Invert _ pes -> prefixedThings (text "invert") $ List1.toList (namedWith <$> pes) where -instance (HasRange qn, HasRange p, HasRange e) => HasRange (RewriteEqn' qn p e) where+      namedWith (Named nm (p, e)) =+        let patexp = pretty p <+> "<-" <+> pretty e in+        case nm of+          Nothing -> patexp+          Just nm -> pretty nm <+> ":" <+> patexp++instance (HasRange qn, HasRange nm, HasRange p, HasRange e) => HasRange (RewriteEqn' qn nm p e) where   getRange = \case     Rewrite es    -> getRange es     Invert qn pes -> getRange (qn, pes) -instance (KillRange qn, KillRange e, KillRange p) => KillRange (RewriteEqn' qn p e) where+instance (KillRange qn, KillRange nm, KillRange e, KillRange p) => KillRange (RewriteEqn' qn nm p e) where   killRange = \case     Rewrite es    -> killRange1 Rewrite es     Invert qn pes -> killRange2 Invert qn pes@@ -2406,7 +2845,7 @@ -- * Information on expanded ellipsis (@...@) ----------------------------------------------------------------------------- --- ^ When the ellipsis in a clause are expanded, we remember that we+-- ^ When the ellipsis in a clause is expanded, we remember that we --   did so. We also store the number of with-arguments that are --   included in the expanded ellipsis. data ExpandedEllipsis@@ -2467,21 +2906,21 @@   _              `compare` WildHole{}     = GT  instance HasRange GenPart where-  getRange p = case p of+  getRange = \case     IdPart x       -> getRange x     BindHole r _   -> r     WildHole i     -> getRange i     NormalHole r _ -> r  instance SetRange GenPart where-  setRange r p = case p of+  setRange r = \case     IdPart x       -> IdPart x     BindHole _ i   -> BindHole r i     WildHole i     -> WildHole i     NormalHole _ i -> NormalHole r i  instance KillRange GenPart where-  killRange p = case p of+  killRange = \case     IdPart x       -> IdPart $ killRange x     BindHole _ i   -> BindHole noRange $ killRange i     WildHole i     -> WildHole $ killRange i

src/full/Agda/Syntax/Concrete.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ApplicativeDo #-}  -- see exprToPattern  {-| The concrete syntax is a raw representation of the program text     without any desugaring at all.  This is what the parser produces.@@ -9,10 +10,14 @@   ( -- * Expressions     Expr(..)   , OpApp(..), fromOrdinary+  , OpAppArgs, OpAppArgs'   , module Agda.Syntax.Concrete.Name-  , appView, AppView(..)-  , isSingleIdentifierP, removeSingletonRawAppP+  , AppView(..), appView, unAppView+  , rawApp, rawAppP+  , isSingleIdentifierP, removeParenP   , isPattern, isAbsurdP, isBinderP+  , exprToPatternWithHoles+  , returnExpr     -- * Bindings   , Binder'(..)   , Binder@@ -20,6 +25,7 @@   , mkBinder   , LamBinding   , LamBinding'(..)+  , dropTypeAndModality   , TypedBinding   , TypedBinding'(..)   , RecordAssignment@@ -28,26 +34,31 @@   , ModuleAssignment(..)   , BoundName(..), mkBoundName_, mkBoundName   , TacticAttribute-  , Telescope -- (..)-  , countTelVars+  , Telescope, Telescope1   , lamBindingsToTelescope   , makePi+  , mkLam, mkLet, mkTLet     -- * Declarations+  , RecordDirective(..)+  , isRecordDirective+  , RecordDirectives   , Declaration(..)   , ModuleApplication(..)   , TypeSignature   , TypeSignatureOrInstanceBlock   , ImportDirective, Using, ImportedName-  , Renaming+  , Renaming, RenamingDirective, HidingDirective   , AsName'(..), AsName   , OpenShortHand(..), RewriteEqn, WithExpr   , LHS(..), Pattern(..), LHSCore(..)   , observeHiding+  , observeRelevance+  , observeModifiers   , LamClause(..)   , RHS, RHS'(..), WhereClause, WhereClause'(..), ExprWhere(..)   , DoStmt(..)   , Pragma(..)-  , Module+  , Module(..)   , ThingWithFixity(..)   , HoleContent, HoleContent'(..)   , topLevelModuleName@@ -58,17 +69,18 @@ import Prelude hiding (null)  import Control.DeepSeq-import Data.Foldable (Foldable)-import Data.Traversable (Traversable, forM, mapM)-import Data.List hiding (null)-import Data.Set (Set) -import Data.Data (Data)+import Data.Data        ( Data )+import Data.Functor.Identity+import Data.Set         ( Set  )+import Data.Text        ( Text )+-- import Data.Traversable ( forM ) +import GHC.Generics     ( Generic )+ import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Fixity-import Agda.Syntax.Notation import Agda.Syntax.Literal  import Agda.Syntax.Concrete.Name@@ -76,14 +88,18 @@  import Agda.TypeChecking.Positivity.Occurrence -import Agda.Utils.Either ( maybeLeft )+import Agda.Utils.Applicative ( forA )+import Agda.Utils.Either      ( maybeLeft ) import Agda.Utils.Lens+import Agda.Utils.List1       ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.List2       ( List2, pattern List2 ) import Agda.Utils.Null  import Agda.Utils.Impossible  data OpApp e-  = SyntaxBindingLambda Range [LamBinding] e+  = SyntaxBindingLambda Range (List1 LamBinding) e     -- ^ An abstraction inside a special syntax declaration     --   (see Issue 358 why we introduce this).   | Ordinary e@@ -127,38 +143,29 @@ -- | Concrete expressions. Should represent exactly what the user wrote. data Expr   = Ident QName                                -- ^ ex: @x@-  | Lit Literal                                -- ^ ex: @1@ or @\"foo\"@+  | Lit Range Literal                          -- ^ ex: @1@ or @\"foo\"@   | QuestionMark Range (Maybe Nat)             -- ^ ex: @?@ or @{! ... !}@   | Underscore Range (Maybe String)            -- ^ ex: @_@ or @_A_5@-  | RawApp Range [Expr]                        -- ^ before parsing operators+  | RawApp Range (List2 Expr)                  -- ^ before parsing operators   | App Range Expr (NamedArg Expr)             -- ^ ex: @e e@, @e {e}@, or @e {x = e}@-  | OpApp Range QName (Set A.Name)-          [NamedArg-             (MaybePlaceholder (OpApp Expr))]  -- ^ ex: @e + e@-                                               -- The 'QName' is-                                               -- possibly ambiguous,-                                               -- but it must-                                               -- correspond to one of-                                               -- the names in the-                                               -- set.+  | OpApp Range QName (Set A.Name) OpAppArgs   -- ^ ex: @e + e@+                                               -- The 'QName' is possibly ambiguous,+                                               -- but it must correspond to one of the names in the set.   | WithApp Range Expr [Expr]                  -- ^ ex: @e | e1 | .. | en@   | HiddenArg Range (Named_ Expr)              -- ^ ex: @{e}@ or @{x=e}@   | InstanceArg Range (Named_ Expr)            -- ^ ex: @{{e}}@ or @{{x=e}}@-  | Lam Range [LamBinding] Expr                -- ^ ex: @\\x {y} -> e@ or @\\(x:A){y:B} -> e@+  | Lam Range (List1 LamBinding) Expr          -- ^ ex: @\\x {y} -> e@ or @\\(x:A){y:B} -> e@   | AbsurdLam Range Hiding                     -- ^ ex: @\\ ()@-  | ExtendedLam Range [LamClause]              -- ^ ex: @\\ { p11 .. p1a -> e1 ; .. ; pn1 .. pnz -> en }@+  | ExtendedLam Range Erased+      (List1 LamClause)                        -- ^ ex: @\\ { p11 .. p1a -> e1 ; .. ; pn1 .. pnz -> en }@   | Fun Range (Arg Expr) Expr                  -- ^ ex: @e -> e@ or @.e -> e@ (NYI: @{e} -> e@)-  | Pi Telescope Expr                          -- ^ ex: @(xs:e) -> e@ or @{xs:e} -> e@-  | Set Range                                  -- ^ ex: @Set@-  | Prop Range                                 -- ^ ex: @Prop@-  | SetN Range Integer                         -- ^ ex: @Set0, Set1, ..@-  | PropN Range Integer                        -- ^ ex: @Prop0, Prop1, ..@+  | Pi Telescope1 Expr                         -- ^ ex: @(xs:e) -> e@ or @{xs:e} -> e@   | Rec Range RecordAssignments                -- ^ ex: @record {x = a; y = b}@, or @record { x = a; M1; M2 }@   | RecUpdate Range Expr [FieldAssignment]     -- ^ ex: @record e {x = a; y = b}@-  | Let Range [Declaration] (Maybe Expr)       -- ^ ex: @let Ds in e@, missing body when parsing do-notation let+  | 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 [DoStmt]                     -- ^ ex: @do x <- m1; m2@+  | DoBlock Range (List1 DoStmt)               -- ^ ex: @do x <- m1; m2@   | Absurd Range                               -- ^ ex: @()@ or @{}@, only in patterns   | As Range Name Expr                         -- ^ ex: @x\@p@, only in patterns   | Dot Range Expr                             -- ^ ex: @.p@, only in patterns@@ -174,12 +181,15 @@   | Generalized Expr   deriving (Data, Eq) +type OpAppArgs = OpAppArgs' Expr+type OpAppArgs' e = [NamedArg (MaybePlaceholder (OpApp e))]+ -- | Concrete patterns. No literals in patterns at the moment. data Pattern   = IdentP QName                           -- ^ @c@ or @x@   | QuoteP Range                           -- ^ @quote@   | AppP Pattern (NamedArg Pattern)        -- ^ @p p'@ or @p {x = p'}@-  | RawAppP Range [Pattern]                -- ^ @p1..pn@ before parsing operators+  | RawAppP Range (List2 Pattern)          -- ^ @p1..pn@ before parsing operators   | OpAppP Range QName (Set A.Name)            [NamedArg Pattern]              -- ^ eg: @p => p'@ for operator @_=>_@                                            -- The 'QName' is possibly@@ -193,17 +203,19 @@   | AbsurdP Range                          -- ^ @()@   | AsP Range Name Pattern                 -- ^ @x\@p@ unused   | DotP Range Expr                        -- ^ @.e@-  | LitP Literal                           -- ^ @0@, @1@, etc.+  | LitP Range Literal                     -- ^ @0@, @1@, etc.   | RecP Range [FieldAssignment' Pattern]  -- ^ @record {x = p; y = q}@   | EqualP Range [(Expr,Expr)]             -- ^ @i = i1@ i.e. cubical face lattice generator-  | EllipsisP Range                        -- ^ @...@, only as left-most pattern.+  | EllipsisP Range (Maybe Pattern)        -- ^ @...@, only as left-most pattern.+                                           --   Second arg is @Nothing@ before expansion, and+                                           --   @Just p@ after expanding ellipsis to @p@.   | WithP Range Pattern                    -- ^ @| p@, for with-patterns.   deriving (Data, Eq)  data DoStmt   = DoBind Range Pattern Expr [LamClause]   -- ^ @p ← e where cs@   | DoThen Expr-  | DoLet Range [Declaration]+  | DoLet Range (List1 Declaration)   deriving (Data, Eq)  -- | A Binder @x\@p@, the pattern is optional@@ -230,6 +242,13 @@     -- ^ . @(xs : e)@ or @{xs : e}@   deriving (Data, 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]+ data BoundName = BName   { boundName   :: Name   , bnameFixity :: Fixity'@@ -250,37 +269,49 @@ type TypedBinding = TypedBinding' Expr  data TypedBinding' e-  = TBind Range [NamedArg Binder] e+  = TBind Range (List1 (NamedArg Binder)) e     -- ^ Binding @(x1\@p1 ... xn\@pn : A)@.-  | TLet  Range [Declaration]+  | TLet  Range (List1 Declaration)     -- ^ Let binding @(let Ds)@ or @(open M args)@.   deriving (Data, Functor, Foldable, Traversable, Eq)  -- | A telescope is a sequence of typed bindings. Bound variables are in scope --   in later types.-type Telescope = [TypedBinding]--countTelVars :: Telescope -> Nat-countTelVars tel =-  sum [ case b of-          TBind _ xs _ -> genericLength xs-          TLet{}       -> 0-      | b <- tel ]+type Telescope1 = List1 TypedBinding+type Telescope  = [TypedBinding]  -- | We can try to get a @Telescope@ from a @[LamBinding]@. --   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 = map $ \case+lamBindingsToTelescope r = fmap $ \case   DomainFull ty -> ty-  DomainFree nm -> TBind r [nm] $ Underscore r Nothing+  DomainFree nm -> TBind r (List1.singleton nm) $ Underscore r Nothing  -- | Smart constructor for @Pi@: check whether the @Telescope@ is empty  makePi :: Telescope -> Expr -> Expr-makePi [] e = e-makePi bs e = Pi bs e+makePi []     = id+makePi (b:bs) = Pi (b :| bs) +-- | Smart constructor for @Lam@: check for non-zero bindings.++mkLam :: Range -> [LamBinding] -> Expr -> Expr+mkLam r []     e = e+mkLam r (x:xs) e = Lam r (x :| xs) e++-- | Smart constructor for @Let@: check for non-zero let bindings.++mkLet :: Range -> [Declaration] -> Expr -> Expr+mkLet r []     e = e+mkLet r (d:ds) e = Let r (d :| ds) (Just e)++-- | Smart constructor for @TLet@: check for non-zero let bindings.++mkTLet :: Range -> [Declaration] -> Maybe (TypedBinding' e)+mkTLet r []     = Nothing+mkTLet r (d:ds) = Just $ TLet r (d :| ds)+ {-| Left hand sides can be written in infix style. For example:      > n + suc m = suc (n + m)@@ -288,17 +319,18 @@     We use fixity information to see which name is actually defined. -}-data LHS = LHS-  { lhsOriginalPattern :: Pattern               -- ^ e.g. @f ps | wps@-  , lhsRewriteEqn      :: [RewriteEqn]          -- ^ @(rewrite e | with p <- e)@ (many)-  , lhsWithExpr        :: [WithHiding WithExpr] -- ^ @with e1 | {e2} | ...@ (many)-  , lhsExpandedEllipsis :: ExpandedEllipsis     -- ^ Did we expand an ellipsis?-  } -- ^ Original pattern (including with-patterns), rewrite equations and with-expressions.+data LHS = LHS  -- ^ Original pattern (including with-patterns), rewrite equations and with-expressions.+  { lhsOriginalPattern :: Pattern+    -- ^ e.g. @f ps | wps@+  , lhsRewriteEqn      :: [RewriteEqn]+    -- ^ @(rewrite e | with p <- e in eq)@ (many)+  , lhsWithExpr        :: [WithExpr]+    -- ^ @with e1 in eq | {e2} | ...@ (many)+  }   deriving (Data, Eq) -type RewriteEqn = RewriteEqn' () Pattern Expr--type WithExpr   = Expr+type RewriteEqn = RewriteEqn' () Name Pattern Expr+type WithExpr   = Named Name (Arg Expr)  -- | Processed (operator-parsed) intermediate form of the core @f ps@ of 'LHS'. --   Corresponds to 'lhsOriginalPattern'.@@ -315,6 +347,10 @@              , lhsWithPatterns :: [Pattern]          -- ^ Non-empty; at least one @(| p)@.              , lhsPats         :: [NamedArg Pattern] -- ^ More application patterns.              }+  | LHSEllipsis+             { lhsEllipsisRange :: Range+             , lhsEllipsisPat   :: LHSCore           -- ^ Pattern that was expanded from an ellipsis @...@.+             }   deriving (Data, Eq)  type RHS = RHS' Expr@@ -323,21 +359,29 @@   | RHS e   deriving (Data, Functor, Foldable, Traversable, Eq) -+-- | @where@ block following a clause. type WhereClause = WhereClause' [Declaration]++-- The generalization @WhereClause'@ is for the sake of Concrete.Generic. data WhereClause' decls-  = NoWhere               -- ^ No @where@ clauses.-  | AnyWhere decls        -- ^ Ordinary @where@.-  | SomeWhere Name Access decls-    -- ^ Named where: @module M where@.-    --   The 'Access' flag applies to the 'Name' (not the module contents!)-    --   and is propagated from the parent function.-  deriving (Data, Functor, Foldable, Traversable, Eq)+  = NoWhere+      -- ^ No @where@ clauses.+  | AnyWhere Range decls+      -- ^ Ordinary @where@.  'Range' of the @where@ keyword.+      --   List of declarations can be empty.+  | SomeWhere Range Name Access decls+      -- ^ Named where: @module M where ds@.+      --   'Range' of the keywords @module@ and @where@.+      --   The 'Access' flag applies to the 'Name' (not the module contents!)+      --   and is propagated from the parent function.+      --   List of declarations can be empty.+  deriving (Data, Eq, Functor, Foldable, Traversable) -data LamClause = LamClause { lamLHS      :: LHS-                           , lamRHS      :: RHS-                           , lamWhere    :: WhereClause -- ^ always 'NoWhere' (see parser)-                           , lamCatchAll :: Bool }+data LamClause = LamClause+  { lamLHS      :: [Pattern]   -- ^ Possibly empty sequence.+  , lamRHS      :: RHS+  , lamCatchAll :: Bool+  }   deriving (Data, Eq)  -- | An expression followed by a where clause.@@ -349,6 +393,8 @@ type ImportDirective = ImportDirective' Name Name type Using           = Using'           Name Name type Renaming        = Renaming'        Name Name+type RenamingDirective = RenamingDirective' Name Name+type HidingDirective   = HidingDirective'   Name Name  -- 'Hiding' is already taken  -- | An imported name can be a module or a defined name. type ImportedName = ImportedName' Name Name@@ -379,6 +425,19 @@ -- | Just type signatures or instance blocks. type TypeSignatureOrInstanceBlock = Declaration +-- | Isolated record directives parsed as Declarations+data RecordDirective+   = Induction (Ranged Induction)+       -- ^ Range of keyword @[co]inductive@.+   | Constructor Name IsInstance+   | Eta         (Ranged HasEta0)+       -- ^ Range of @[no-]eta-equality@ keyword.+   | PatternOrCopattern Range+       -- ^ If declaration @pattern@ is present, give its range.+   deriving (Data,Eq,Show)++type RecordDirectives = RecordDirectives' (Name, IsInstance)+ {-| The representation type of a declaration. The comments indicate     which type in the intended family the constructor targets. -}@@ -394,13 +453,14 @@   | Data        Range Name [LamBinding] Expr [TypeSignatureOrInstanceBlock]   | DataDef     Range Name [LamBinding] [TypeSignatureOrInstanceBlock]   | RecordSig   Range Name [LamBinding] Expr -- ^ lone record signature in mutual block-  | RecordDef   Range Name (Maybe (Ranged Induction)) (Maybe HasEta) (Maybe (Name, IsInstance)) [LamBinding] [Declaration]-  | Record      Range Name (Maybe (Ranged Induction)) (Maybe HasEta) (Maybe (Name, IsInstance)) [LamBinding] Expr [Declaration]-    -- ^ The optional name is a name for the record constructor.-  | Infix Fixity [Name]+  | RecordDef   Range Name RecordDirectives [LamBinding] [Declaration]+  | Record      Range Name RecordDirectives [LamBinding] Expr [Declaration]+  | RecordDirective RecordDirective -- ^ Should not survive beyond the parser+  | Infix Fixity (List1 Name)   | Syntax      Name Notation -- ^ notation declaration for a name   | PatternSyn  Range Name [Arg Name] Pattern   | Mutual      Range [Declaration]  -- @Range@ of the whole @mutual@ block.+  | InterleavedMutual Range [Declaration]   | Abstract    Range [Declaration]   | Private     Range Origin [Declaration]     -- ^ In "Agda.Syntax.Concrete.Definitions" we generate private blocks@@ -410,6 +470,7 @@     -- ^ The 'Range' here (exceptionally) only refers to the range of the     --   @instance@ keyword.  The range of the whole block @InstanceB r ds@     --   is @fuseRange r ds@.+  | LoneConstructor Range [Declaration]   | Macro       Range [Declaration]   | Postulate   Range [TypeSignatureOrInstanceBlock]   | Primitive   Range [TypeSignature]@@ -422,6 +483,12 @@   | Pragma      Pragma   deriving (Data, Eq) +-- | Extract a record directive+isRecordDirective :: Declaration -> Maybe RecordDirective+isRecordDirective (RecordDirective r) = Just r+isRecordDirective (InstanceB r [RecordDirective (Constructor n p)]) = Just (Constructor n (InstanceDef r))+isRecordDirective _ = Nothing+ data ModuleApplication   = SectionApp Range Telescope Expr     -- ^ @tel. M args@@@ -430,7 +497,7 @@   deriving (Data, Eq)  data OpenShortHand = DoOpen | DontOpen-  deriving (Data, Eq, Show)+  deriving (Data, Eq, Show, Generic)  -- Pragmas ---------------------------------------------------------------- @@ -443,14 +510,15 @@   | StaticPragma              Range QName   | InlinePragma              Range Bool QName  -- ^ INLINE or NOINLINE -  | ImpossiblePragma          Range+  | ImpossiblePragma          Range [String]     -- ^ 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).-  | WarningOnUsage            Range QName String+  | WarningOnUsage            Range QName Text     -- ^ Applies to the named function-  | WarningOnImport           Range String+  | WarningOnImport           Range Text     -- ^ Applies to the current module   | InjectivePragma           Range QName     -- ^ Mark a definition as injective for the pattern matching unifier.@@ -477,7 +545,10 @@  -- | Modules: Top-level pragmas plus other top-level declarations. -type Module = ([Pragma], [Declaration])+data Module = Mod+  { modPragmas :: [Pragma]+  , modDecls   :: [Declaration]+  }  -- | Computes the top-level module name. --@@ -487,8 +558,8 @@ -- See 'spanAllowedBeforeModule'.  topLevelModuleName :: Module -> TopLevelModuleName-topLevelModuleName (_, []) = __IMPOSSIBLE__-topLevelModuleName (_, ds) = case spanAllowedBeforeModule ds of+topLevelModuleName (Mod _ []) = __IMPOSSIBLE__+topLevelModuleName (Mod _ ds) = case spanAllowedBeforeModule ds of   (_, Module _ n _ _ : _) -> toTopLevelModuleName n   _ -> __IMPOSSIBLE__ @@ -512,13 +583,25 @@  --------------------------------------------------------------------------}  -- | Extended content of an interaction hole.-data HoleContent' qn p e-  = HoleContentExpr    e                    -- ^ @e@-  | HoleContentRewrite [RewriteEqn' qn p e] -- ^ @(rewrite | invert) e0 | ... | en@+data HoleContent' qn nm p e+  = HoleContentExpr    e                       -- ^ @e@+  | HoleContentRewrite [RewriteEqn' qn nm p e] -- ^ @(rewrite | invert) e0 | ... | en@   deriving (Functor, Foldable, Traversable) -type HoleContent = HoleContent' () Pattern Expr+type HoleContent = HoleContent' () Name Pattern Expr +---------------------------------------------------------------------------+-- * Smart constructors+---------------------------------------------------------------------------++rawApp :: List1 Expr -> Expr+rawApp es@(e1 :| e2 : rest) = RawApp (getRange es) $ List2 e1 e2 rest+rawApp (e :| []) = e++rawAppP :: List1 Pattern -> Pattern+rawAppP ps@(p1 :| p2 : rest) = RawAppP (getRange ps) $ List2 p1 p2 rest+rawAppP (p :| []) = p+ {--------------------------------------------------------------------------     Views  --------------------------------------------------------------------------}@@ -527,11 +610,11 @@ data AppView = AppView Expr [NamedArg Expr]  appView :: Expr -> AppView-appView e =-  case e of-    App r e1 e2     -> vApp (appView e1) e2-    RawApp _ (e:es) -> AppView e $ map arg es-    _               -> AppView e []+appView = \case+    App r e1 e2      -> vApp (appView e1) e2+    RawApp _ (List2 e1 e2 es)+                     -> AppView e1 $ map arg (e2:es)+    e                -> AppView e []   where     vApp (AppView e es) arg = AppView e (es ++ [arg]) @@ -539,78 +622,123 @@     arg (InstanceArg _ e) = makeInstance $ defaultArg e     arg e                 = defaultArg (unnamed e) +unAppView :: AppView -> Expr+unAppView (AppView e nargs) = rawApp (e :| map unNamedArg nargs)++  where+    unNamedArg narg = ($ unArg narg) $ case getHiding narg of+      Hidden     -> HiddenArg (getRange narg)+      NotHidden  -> namedThing+      Instance{} -> InstanceArg (getRange narg)+ isSingleIdentifierP :: Pattern -> Maybe Name-isSingleIdentifierP p = case removeSingletonRawAppP p of+isSingleIdentifierP = \case   IdentP (QName x) -> Just x   WildP r          -> Just $ noName r+  ParenP _ p       -> isSingleIdentifierP p   _                -> Nothing -removeSingletonRawAppP :: Pattern -> Pattern-removeSingletonRawAppP p = case p of-    RawAppP _ [p'] -> removeSingletonRawAppP p'-    ParenP _ p'    -> removeSingletonRawAppP p'-    _ -> p+removeParenP :: Pattern -> Pattern+removeParenP = \case+    ParenP _ p -> removeParenP p+    p -> p  -- | Observe the hiding status of an expression- observeHiding :: Expr -> WithHiding Expr observeHiding = \case-  RawApp _ [e]                    -> observeHiding e   HiddenArg _   (Named Nothing e) -> WithHiding Hidden e   InstanceArg _ (Named Nothing e) -> WithHiding (Instance NoOverlap) e   e                               -> WithHiding NotHidden e +-- | Observe the relevance status of an expression+observeRelevance :: Expr -> (Relevance, Expr)+observeRelevance = \case+  Dot _ e       -> (Irrelevant, e)+  DoubleDot _ e -> (NonStrict, e)+  e             -> (Relevant, e)++-- | Observe various modifiers applied to an expression+observeModifiers :: Expr -> Arg Expr+observeModifiers e =+  let (rel, WithHiding hid e') = fmap observeHiding (observeRelevance e) in+  setRelevance rel $ setHiding hid $ defaultArg e'++returnExpr :: Expr -> Maybe Expr+returnExpr (Pi _ e)        = returnExpr e+returnExpr (Fun _ _  e)    = returnExpr e+returnExpr (Let _ _ e)     = returnExpr =<< e+returnExpr (Paren _ e)     = returnExpr e+returnExpr (Generalized e) = returnExpr e+returnExpr e               = pure e+ -- | Turn an expression into a pattern. Fails if the expression is not a --   valid pattern.  isPattern :: Expr -> Maybe Pattern-isPattern = \case-  Ident x         -> return $ IdentP x-  App _ e1 e2     -> AppP <$> isPattern e1 <*> mapM (mapM isPattern) e2-  Paren r e       -> ParenP r <$> isPattern e-  Underscore r _  -> return $ WildP r-  Absurd r        -> return $ AbsurdP r-  As r x e        -> pushUnderBracesP r (AsP r x) <$> isPattern e-  Dot r e         -> return $ pushUnderBracesE r (DotP r) e-  Lit l           -> return $ LitP l-  HiddenArg r e   -> HiddenP r <$> mapM isPattern e-  InstanceArg r e -> InstanceP r <$> mapM isPattern e-  RawApp r es     -> RawAppP r <$> mapM isPattern es-  Quote r         -> return $ QuoteP r-  Equal r e1 e2   -> return $ EqualP r [(e1, e2)]-  Ellipsis r      -> return $ EllipsisP r-  Rec r es        -> do-    fs <- mapM maybeLeft es-    RecP r <$> mapM (mapM isPattern) fs-  -- WithApp has already lost the range information of the bars '|'-  WithApp r e es  -> do-    p  <- isPattern e-    ps <- forM es $ \ e -> do-      p <- isPattern e-      pure $ defaultNamedArg $ WithP (getRange e) p   -- TODO #2822: Range!-    return $ foldl AppP p ps-  _ -> Nothing+isPattern = exprToPattern (const Nothing) +-- | Turn an expression into a pattern, turning non-pattern subexpressions into 'WildP'.++exprToPatternWithHoles :: Expr -> Pattern+exprToPatternWithHoles = runIdentity . exprToPattern (Identity . WildP . getRange)++-- | Generic expression to pattern conversion.++exprToPattern :: Applicative m+  => (Expr -> m Pattern)  -- ^ Default result for non-pattern things.+  -> Expr                 -- ^ The expression to translate.+  -> m Pattern            -- ^ The translated pattern (maybe).+exprToPattern fallback = loop   where+  loop = \case+    Ident       x        -> pure $ IdentP x+    App         _ e1 e2  -> AppP <$> loop e1 <*> traverse (traverse loop) e2+    Paren       r e      -> ParenP r <$> loop e+    Underscore  r _      -> pure $ WildP r+    Absurd      r        -> pure $ AbsurdP r+    As          r x e    -> pushUnderBracesP r (AsP r x) <$> loop e+    Dot         r e      -> pure $ pushUnderBracesE r (DotP r) 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.+    e@(Lit _ LitFloat{}) -> fallback e+    Lit         r l      -> pure $ LitP r l+    HiddenArg   r e      -> HiddenP   r <$> traverse loop e+    InstanceArg r e      -> InstanceP r <$> traverse loop e+    RawApp      r es     -> RawAppP   r <$> traverse loop es+    Quote       r        -> pure $ QuoteP r+    Equal       r e1 e2  -> pure $ EqualP r [(e1, e2)]+    Ellipsis    r        -> pure $ EllipsisP r Nothing+    e@(Rec r es)+        -- We cannot translate record expressions with module parts.+      | Just fs <- mapM maybeLeft es -> RecP r <$> traverse (traverse loop) fs+      | otherwise -> fallback e+    -- WithApp has already lost the range information of the bars '|'+    WithApp     r e es   -> do -- ApplicativeDo+      p  <- loop e+      ps <- forA es $ \ e -> do -- ApplicativeDo+        p <- loop e+        pure $ defaultNamedArg $ WithP (getRange e) p   -- TODO #2822: Range!+      pure $ foldl AppP p ps+    e -> fallback e -    pushUnderBracesP :: Range -> (Pattern -> Pattern) -> (Pattern -> Pattern)-    pushUnderBracesP r f = \case-      HiddenP _ p   -> HiddenP r (fmap f p)-      InstanceP _ p -> InstanceP r (fmap f p)-      p             -> f p+  pushUnderBracesP :: Range -> (Pattern -> Pattern) -> (Pattern -> Pattern)+  pushUnderBracesP r f = \case+    HiddenP   _ p   -> HiddenP   r $ fmap f p+    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+  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  isAbsurdP :: Pattern -> Maybe (Range, Hiding) isAbsurdP = \case   AbsurdP r      -> pure (r, NotHidden)   AsP _ _      p -> isAbsurdP p   ParenP _     p -> isAbsurdP p-  RawAppP _ [p]  -> isAbsurdP p   HiddenP   _ np -> (Hidden <$)              <$> isAbsurdP (namedThing np)   InstanceP _ np -> (Instance YesOverlap <$) <$> isAbsurdP (namedThing np)   _ -> Nothing@@ -618,9 +746,9 @@ isBinderP :: Pattern -> Maybe Binder isBinderP = \case   IdentP qn  -> mkBinder_ <$> isUnqualified qn-  WildP r    -> pure $ mkBinder_ (Name r InScope [Hole])-  AsP r n p  -> pure $ Binder (Just p) (mkBoundName_ n)-  ParenP r p -> pure $ Binder (Just p) (mkBoundName_ $ Name r InScope [Hole])+  WildP r    -> pure $ mkBinder_ $ setRange r simpleHole+  AsP r n p  -> pure $ Binder (Just p) $ mkBoundName_ n+  ParenP r p -> pure $ Binder (Just p) $ mkBoundName_ $ setRange r simpleHole   _ -> Nothing  {--------------------------------------------------------------------------@@ -649,31 +777,29 @@   mapHiding f (DomainFull a) = DomainFull $ mapHiding f a  instance LensHiding TypedBinding where-  getHiding (TBind _ (x : _) _) = getHiding x   -- Slightly dubious-  getHiding (TBind _ [] _)      = __IMPOSSIBLE__+  getHiding (TBind _ (x :| _) _) = getHiding x   -- Slightly dubious   getHiding TLet{}              = mempty-  mapHiding f (TBind r xs e) = TBind r ((map . mapHiding) f xs) e+  mapHiding f (TBind r xs e) = TBind r (fmap (mapHiding f) xs) e   mapHiding f b@TLet{}       = b  instance LensRelevance TypedBinding where-  getRelevance (TBind _ (x : _) _) = getRelevance x   -- Slightly dubious-  getRelevance (TBind _ [] _)      = __IMPOSSIBLE__-  getRelevance TLet{}              = mempty-  mapRelevance f (TBind r xs e) = TBind r ((map . mapRelevance) f xs) e+  getRelevance (TBind _ (x :|_) _) = getRelevance x   -- Slightly dubious+  getRelevance TLet{}              = unitRelevance+  mapRelevance f (TBind r xs e) = TBind r (fmap (mapRelevance f) xs) e   mapRelevance f b@TLet{}       = b  -- HasRange instances ------------------------------------------------------------------------  instance HasRange e => HasRange (OpApp e) where-  getRange e = case e of+  getRange = \case     Ordinary e -> getRange e     SyntaxBindingLambda r _ _ -> r  instance HasRange Expr where   getRange = \case       Ident x            -> getRange x-      Lit x              -> getRange x+      Lit r _            -> r       QuestionMark r _   -> r       Underscore r _     -> r       App r _ _          -> r@@ -682,13 +808,9 @@       WithApp r _ _      -> r       Lam r _ _          -> r       AbsurdLam r _      -> r-      ExtendedLam r _    -> r+      ExtendedLam r _ _  -> r       Fun r _ _          -> r       Pi b e             -> fuseRange b e-      Set r              -> r-      Prop r             -> r-      SetN r _           -> r-      PropN r _          -> r       Let r _ _          -> r       Paren r _          -> r       IdiomBrackets r _  -> r@@ -730,9 +852,9 @@   getRange = getRange . boundName  instance HasRange WhereClause where-  getRange  NoWhere         = noRange-  getRange (AnyWhere ds)    = getRange ds-  getRange (SomeWhere _ _ ds) = getRange ds+  getRange  NoWhere             = noRange+  getRange (AnyWhere r ds)      = getRange (r, ds)+  getRange (SomeWhere r x _ ds) = getRange (r, x, ds)  instance HasRange ModuleApplication where   getRange (SectionApp r _ _) = r@@ -744,6 +866,12 @@ instance HasRange ModuleAssignment where   getRange (ModuleAssignment a b c) = fuseRange a b `fuseRange` c +instance HasRange RecordDirective where+  getRange (Induction a)          = getRange a+  getRange (Eta a    )            = getRange a+  getRange (Constructor a b)      = getRange (a, b)+  getRange (PatternOrCopattern r) = r+ instance HasRange Declaration where   getRange (TypeSig _ _ x t)       = fuseRange x t   getRange (FieldSig _ _ x t)      = fuseRange x t@@ -753,9 +881,12 @@   getRange (Data r _ _ _ _)        = r   getRange (DataDef r _ _ _)       = r   getRange (RecordSig r _ _ _)     = r-  getRange (RecordDef r _ _ _ _ _ _) = r-  getRange (Record r _ _ _ _ _ _ _)  = r+  getRange (RecordDef r _ _ _ _)   = r+  getRange (Record r _ _ _ _ _)    = r+  getRange (RecordDirective r)     = getRange r   getRange (Mutual r _)            = r+  getRange (InterleavedMutual r _) = r+  getRange (LoneConstructor r _)   = r   getRange (Abstract r _)          = r   getRange (Generalize r _)        = r   getRange (Open r _ _)            = r@@ -775,19 +906,20 @@   getRange (Pragma p)              = getRange p  instance HasRange LHS where-  getRange (LHS p eqns ws ell) = p `fuseRange` eqns `fuseRange` ws+  getRange (LHS p eqns ws) = p `fuseRange` eqns `fuseRange` ws  instance HasRange LHSCore where   getRange (LHSHead f ps)              = fuseRange f ps   getRange (LHSProj d ps1 lhscore ps2) = d `fuseRange` ps1 `fuseRange` lhscore `fuseRange` ps2   getRange (LHSWith f wps ps)          = f `fuseRange` wps `fuseRange` ps+  getRange (LHSEllipsis r p)           = r  instance HasRange RHS where   getRange AbsurdRHS = noRange   getRange (RHS e)   = getRange e  instance HasRange LamClause where-  getRange (LamClause lhs rhs wh _) = getRange (lhs, rhs, wh)+  getRange (LamClause lhs rhs _) = getRange (lhs, rhs)  instance HasRange DoStmt where   getRange (DoBind r _ _ _) = r@@ -803,7 +935,7 @@   getRange (StaticPragma r _)                = r   getRange (InjectivePragma r _)             = r   getRange (InlinePragma r _ _)              = r-  getRange (ImpossiblePragma r)              = r+  getRange (ImpossiblePragma r _)            = r   getRange (EtaPragma r _)                   = r   getRange (TerminationCheckPragma r _)      = r   getRange (NoCoverageCheckPragma r)         = r@@ -827,14 +959,14 @@   getRange (WildP r)          = r   getRange (AsP r _ _)        = r   getRange (AbsurdP r)        = r-  getRange (LitP l)           = getRange l+  getRange (LitP r _)         = r   getRange (QuoteP r)         = r   getRange (HiddenP r _)      = r   getRange (InstanceP r _)    = r   getRange (DotP r _)         = r   getRange (RecP r _)         = r   getRange (EqualP r _)       = r-  getRange (EllipsisP r)      = r+  getRange (EllipsisP r _)    = r   getRange (WithP r _)        = r  -- SetRange instances@@ -849,14 +981,14 @@   setRange r (WildP _)          = WildP r   setRange r (AsP _ x p)        = AsP r (setRange r x) p   setRange r (AbsurdP _)        = AbsurdP r-  setRange r (LitP l)           = LitP (setRange r l)+  setRange r (LitP _ l)         = LitP r l   setRange r (QuoteP _)         = QuoteP r   setRange r (HiddenP _ p)      = HiddenP r p   setRange r (InstanceP _ p)    = InstanceP r p   setRange r (DotP _ e)         = DotP r e   setRange r (RecP _ fs)        = RecP r fs   setRange r (EqualP _ es)      = EqualP r es-  setRange r (EllipsisP _)      = EllipsisP r+  setRange r (EllipsisP _ mp)   = EllipsisP r mp   setRange r (WithP _ p)        = WithP r p  instance SetRange TypedBinding where@@ -881,6 +1013,12 @@ instance KillRange BoundName where   killRange (BName n f t) = killRange3 BName n f t +instance KillRange RecordDirective where+  killRange (Induction a)          = killRange1 Induction a+  killRange (Eta a    )            = killRange1 Eta a+  killRange (Constructor a b)      = killRange2 Constructor a b+  killRange (PatternOrCopattern _) = PatternOrCopattern noRange+ instance KillRange Declaration where   killRange (TypeSig i t n e)       = killRange3 (TypeSig i) t n e   killRange (FieldSig i t n e)      = killRange4 FieldSig i t n e@@ -891,12 +1029,15 @@   killRange (Data _ n l e c)        = killRange4 (Data noRange) n l e c   killRange (DataDef _ n l c)       = killRange3 (DataDef noRange) n l c   killRange (RecordSig _ n l e)     = killRange3 (RecordSig noRange) n l e-  killRange (RecordDef _ n mi mb mn k d) = killRange6 (RecordDef noRange) n mi mb mn k d-  killRange (Record _ n mi mb mn k e d)  = killRange7 (Record noRange) n mi mb mn k e d+  killRange (RecordDef _ n dir k d) = killRange4 (RecordDef noRange) n dir k d+  killRange (RecordDirective a)     = killRange1 RecordDirective a+  killRange (Record _ n dir k e d)  = killRange5 (Record noRange) n dir k e d   killRange (Infix f n)             = killRange2 Infix f n   killRange (Syntax n no)           = killRange1 (\n -> Syntax n no) n   killRange (PatternSyn _ n ns p)   = killRange3 (PatternSyn noRange) n ns p   killRange (Mutual _ d)            = killRange1 (Mutual noRange) d+  killRange (InterleavedMutual _ d) = killRange1 (InterleavedMutual noRange) d+  killRange (LoneConstructor _ d)   = killRange1 (LoneConstructor noRange) d   killRange (Abstract _ d)          = killRange1 (Abstract noRange) d   killRange (Private _ o d)         = killRange2 (Private noRange) o d   killRange (InstanceB _ d)         = killRange1 (InstanceB noRange) d@@ -912,54 +1053,50 @@   killRange (Pragma p)              = killRange1 Pragma p  instance KillRange Expr where-  killRange (Ident q)            = killRange1 Ident q-  killRange (Lit l)              = killRange1 Lit l-  killRange (QuestionMark _ n)   = QuestionMark noRange n-  killRange (Underscore _ n)     = Underscore noRange n-  killRange (RawApp _ e)         = killRange1 (RawApp noRange) e-  killRange (App _ e a)          = killRange2 (App noRange) e a-  killRange (OpApp _ n ns o)     = killRange3 (OpApp noRange) n ns o-  killRange (WithApp _ e es)     = killRange2 (WithApp noRange) e es-  killRange (HiddenArg _ n)      = killRange1 (HiddenArg noRange) n-  killRange (InstanceArg _ n)    = killRange1 (InstanceArg noRange) n-  killRange (Lam _ l e)          = killRange2 (Lam noRange) l e-  killRange (AbsurdLam _ h)      = killRange1 (AbsurdLam noRange) h-  killRange (ExtendedLam _ lrw)  = killRange1 (ExtendedLam noRange) lrw-  killRange (Fun _ e1 e2)        = killRange2 (Fun noRange) e1 e2-  killRange (Pi t e)             = killRange2 Pi t e-  killRange (Set _)              = Set noRange-  killRange (Prop _)             = Prop noRange-  killRange (SetN _ n)           = SetN noRange n-  killRange (PropN _ n)          = PropN noRange n-  killRange (Rec _ ne)           = killRange1 (Rec noRange) ne-  killRange (RecUpdate _ e ne)   = killRange2 (RecUpdate noRange) e ne-  killRange (Let _ d e)          = killRange2 (Let noRange) d e-  killRange (Paren _ e)          = killRange1 (Paren noRange) e-  killRange (IdiomBrackets _ es) = killRange1 (IdiomBrackets noRange) es-  killRange (DoBlock _ ss)       = killRange1 (DoBlock noRange) ss-  killRange (Absurd _)           = Absurd noRange-  killRange (As _ n e)           = killRange2 (As noRange) n e-  killRange (Dot _ e)            = killRange1 (Dot noRange) e-  killRange (DoubleDot _ e)      = killRange1 (DoubleDot noRange) e-  killRange (ETel t)             = killRange1 ETel t-  killRange (Quote _)            = Quote noRange-  killRange (QuoteTerm _)        = QuoteTerm noRange-  killRange (Unquote _)          = Unquote noRange-  killRange (Tactic _ t)         = killRange1 (Tactic noRange) t-  killRange (DontCare e)         = killRange1 DontCare e-  killRange (Equal _ x y)        = Equal noRange x y-  killRange (Ellipsis _)         = Ellipsis noRange-  killRange (Generalized e)      = killRange1 Generalized e+  killRange (Ident q)             = killRange1 Ident q+  killRange (Lit _ l)             = killRange1 (Lit noRange) l+  killRange (QuestionMark _ n)    = QuestionMark noRange n+  killRange (Underscore _ n)      = Underscore noRange n+  killRange (RawApp _ e)          = killRange1 (RawApp noRange) e+  killRange (App _ e a)           = killRange2 (App noRange) e a+  killRange (OpApp _ n ns o)      = killRange3 (OpApp noRange) n ns o+  killRange (WithApp _ e es)      = killRange2 (WithApp noRange) e es+  killRange (HiddenArg _ n)       = killRange1 (HiddenArg noRange) n+  killRange (InstanceArg _ n)     = killRange1 (InstanceArg noRange) n+  killRange (Lam _ l e)           = killRange2 (Lam noRange) l e+  killRange (AbsurdLam _ h)       = killRange1 (AbsurdLam noRange) h+  killRange (ExtendedLam _ e lrw) = killRange2 (ExtendedLam noRange) e lrw+  killRange (Fun _ e1 e2)         = killRange2 (Fun noRange) e1 e2+  killRange (Pi t e)              = killRange2 Pi t e+  killRange (Rec _ ne)            = killRange1 (Rec noRange) ne+  killRange (RecUpdate _ e ne)    = killRange2 (RecUpdate noRange) e ne+  killRange (Let _ d e)           = killRange2 (Let noRange) d e+  killRange (Paren _ e)           = killRange1 (Paren noRange) e+  killRange (IdiomBrackets _ es)  = killRange1 (IdiomBrackets noRange) es+  killRange (DoBlock _ ss)        = killRange1 (DoBlock noRange) ss+  killRange (Absurd _)            = Absurd noRange+  killRange (As _ n e)            = killRange2 (As noRange) n e+  killRange (Dot _ e)             = killRange1 (Dot noRange) e+  killRange (DoubleDot _ e)       = killRange1 (DoubleDot noRange) e+  killRange (ETel t)              = killRange1 ETel t+  killRange (Quote _)             = Quote noRange+  killRange (QuoteTerm _)         = QuoteTerm noRange+  killRange (Unquote _)           = Unquote noRange+  killRange (Tactic _ t)          = killRange1 (Tactic noRange) t+  killRange (DontCare e)          = killRange1 DontCare e+  killRange (Equal _ x y)         = Equal noRange x y+  killRange (Ellipsis _)          = Ellipsis noRange+  killRange (Generalized e)       = killRange1 Generalized e  instance KillRange LamBinding where   killRange (DomainFree b) = killRange1 DomainFree b   killRange (DomainFull t) = killRange1 DomainFull t  instance KillRange LHS where-  killRange (LHS p r w e)  = killRange4 LHS p r w e+  killRange (LHS p r w)  = killRange3 LHS p r w  instance KillRange LamClause where-  killRange (LamClause a b c d) = killRange4 LamClause a b c d+  killRange (LamClause a b c) = killRange3 LamClause a b c  instance KillRange DoStmt where   killRange (DoBind r p e w) = killRange4 DoBind r p e w@@ -986,11 +1123,11 @@   killRange (AbsurdP _)       = AbsurdP noRange   killRange (AsP _ n p)       = killRange2 (AsP noRange) n p   killRange (DotP _ e)        = killRange1 (DotP noRange) e-  killRange (LitP l)          = killRange1 LitP l+  killRange (LitP _ l)        = killRange1 (LitP noRange) l   killRange (QuoteP _)        = QuoteP noRange   killRange (RecP _ fs)       = killRange1 (RecP noRange) fs   killRange (EqualP _ es)     = killRange1 (EqualP noRange) es-  killRange (EllipsisP _)     = EllipsisP noRange+  killRange (EllipsisP _ mp)  = killRange1 (EllipsisP noRange) mp   killRange (WithP _ p)       = killRange1 (WithP noRange) p  instance KillRange Pragma where@@ -1002,7 +1139,7 @@   killRange (InlinePragma _ b q)              = killRange1 (InlinePragma noRange b) q   killRange (CompilePragma _ b q s)           = killRange1 (\ q -> CompilePragma noRange b q s) q   killRange (ForeignPragma _ b s)             = ForeignPragma noRange b s-  killRange (ImpossiblePragma _)              = ImpossiblePragma noRange+  killRange (ImpossiblePragma _ strs)         = ImpossiblePragma noRange strs   killRange (TerminationCheckPragma _ t)      = TerminationCheckPragma noRange (killRange t)   killRange (NoCoverageCheckPragma _)         = NoCoverageCheckPragma noRange   killRange (WarningOnUsage _ nm str)         = WarningOnUsage noRange (killRange nm) str@@ -1023,9 +1160,9 @@   killRange (TLet r ds)   = killRange2 TLet r ds  instance KillRange WhereClause where-  killRange NoWhere         = NoWhere-  killRange (AnyWhere d)    = killRange1 AnyWhere d-  killRange (SomeWhere n a d) = killRange3 SomeWhere n a d+  killRange NoWhere             = NoWhere+  killRange (AnyWhere r d)      = killRange1 (AnyWhere noRange) d+  killRange (SomeWhere r n a d) = killRange3 (SomeWhere noRange) n a d  ------------------------------------------------------------------------ -- NFData instances@@ -1033,68 +1170,70 @@ -- | 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)  = rnf a-  rnf (Fun _ a b)        = rnf a `seq` rnf b-  rnf (Pi a b)           = rnf a `seq` rnf b-  rnf (Set _)            = ()-  rnf (Prop _)           = ()-  rnf (SetN _ a)         = rnf a-  rnf (PropN _ a)        = rnf a-  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 (ETel 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 (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 (ETel 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  -- | Ranges are not forced.  instance NFData Pattern where-  rnf (IdentP a) = rnf a-  rnf (QuoteP _) = ()-  rnf (AppP a b) = rnf a `seq` rnf b-  rnf (RawAppP _ a) = rnf a+  rnf (IdentP a)       = rnf a+  rnf (QuoteP _)       = ()+  rnf (AppP a b)       = rnf a `seq` rnf b+  rnf (RawAppP _ a)    = rnf a   rnf (OpAppP _ a b c) = rnf a `seq` rnf b `seq` rnf c-  rnf (HiddenP _ a) = rnf a-  rnf (InstanceP _ a) = rnf a-  rnf (ParenP _ a) = rnf a-  rnf (WildP _) = ()-  rnf (AbsurdP _) = ()-  rnf (AsP _ a b) = rnf a `seq` rnf b-  rnf (DotP _ a) = rnf a-  rnf (LitP a) = rnf a-  rnf (RecP _ a) = rnf a-  rnf (EqualP _ es) = rnf es-  rnf (EllipsisP _) = ()-  rnf (WithP _ a) = rnf a+  rnf (HiddenP _ a)    = rnf a+  rnf (InstanceP _ a)  = rnf a+  rnf (ParenP _ a)     = rnf a+  rnf (WildP _)        = ()+  rnf (AbsurdP _)      = ()+  rnf (AsP _ a b)      = rnf a `seq` rnf b+  rnf (DotP _ a)       = rnf a+  rnf (LitP _ a)       = rnf a+  rnf (RecP _ a)       = rnf a+  rnf (EqualP _ es)    = rnf es+  rnf (EllipsisP _ mp) = rnf mp+  rnf (WithP _ a)      = rnf a  -- | Ranges are not forced. +instance NFData RecordDirective where+  rnf (Induction a)          = rnf a+  rnf (Eta a    )            = rnf a+  rnf (Constructor a b)      = rnf (a, b)+  rnf (PatternOrCopattern _) = ()+ instance NFData Declaration where   rnf (TypeSig a b c d)       = rnf a `seq` rnf b `seq` rnf c `seq` rnf d   rnf (FieldSig a b c d)      = rnf a `seq` rnf b `seq` rnf c `seq` rnf d@@ -1105,12 +1244,15 @@   rnf (Data _ a b c d)        = rnf a `seq` rnf b `seq` rnf c `seq` rnf d   rnf (DataDef _ a b c)       = rnf a `seq` rnf b `seq` rnf c   rnf (RecordSig _ a b c)     = rnf a `seq` rnf b `seq` rnf c-  rnf (RecordDef _ a b c d e f) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f-  rnf (Record _ a b c d e f g)  = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f `seq` rnf g+  rnf (RecordDef _ a b c d)   = rnf (a, b, c, d)+  rnf (Record _ a b c d e)    = rnf (a, b, c, d, e)+  rnf (RecordDirective a)     = rnf a   rnf (Infix a b)             = rnf a `seq` rnf b   rnf (Syntax a b)            = rnf a `seq` rnf b   rnf (PatternSyn _ a b c)    = rnf a `seq` rnf b `seq` rnf c   rnf (Mutual _ a)            = rnf a+  rnf (InterleavedMutual _ a) = rnf a+  rnf (LoneConstructor _ a)   = rnf a   rnf (Abstract _ a)          = rnf a   rnf (Private _ _ a)         = rnf a   rnf (InstanceB _ a)         = rnf a@@ -1125,6 +1267,8 @@   rnf (UnquoteDef _ a b)      = rnf a `seq` rnf b   rnf (Pragma a)              = rnf a +instance NFData OpenShortHand+ -- | Ranges are not forced.  instance NFData Pragma where@@ -1136,7 +1280,7 @@   rnf (StaticPragma _ a)                = rnf a   rnf (InjectivePragma _ a)             = rnf a   rnf (InlinePragma _ _ a)              = rnf a-  rnf (ImpossiblePragma _)              = ()+  rnf (ImpossiblePragma _ a)            = rnf a   rnf (EtaPragma _ a)                   = rnf a   rnf (TerminationCheckPragma _ a)      = rnf a   rnf (NoCoverageCheckPragma _)         = ()@@ -1174,7 +1318,7 @@ -- | Ranges are not forced.  instance NFData LHS where-  rnf (LHS a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  rnf (LHS a b c) = rnf a `seq` rnf b `seq` rnf c  instance NFData a => NFData (FieldAssignment' a) where   rnf (FieldAssignment a b) = rnf a `seq` rnf b@@ -1183,12 +1327,12 @@   rnf (ModuleAssignment a b c) = rnf a `seq` rnf b `seq` rnf c  instance NFData a => NFData (WhereClause' a) where-  rnf NoWhere         = ()-  rnf (AnyWhere a)    = rnf a-  rnf (SomeWhere a b c) = rnf a `seq` rnf b `seq` rnf c+  rnf NoWhere             = ()+  rnf (AnyWhere _ a)      = rnf a+  rnf (SomeWhere _ a b c) = rnf a `seq` rnf b `seq` rnf c  instance NFData LamClause where-  rnf (LamClause a b c d) = rnf (a, b, c, d)+  rnf (LamClause a b c) = rnf (a, b, c)  instance NFData a => NFData (LamBinding' a) where   rnf (DomainFree a) = rnf a

src/full/Agda/Syntax/Concrete/Attribute.hs view

@@ -16,6 +16,7 @@ import Agda.Syntax.Concrete.Pretty () --instance only import Agda.Syntax.Position +import Agda.Utils.List1 (List1, pattern (:|)) import Agda.Utils.Pretty (prettyShow)  -- import Agda.Utils.Functor@@ -27,6 +28,7 @@   | QuantityAttribute  Quantity   | TacticAttribute Expr   | CohesionAttribute Cohesion+  | LockAttribute      Lock   deriving (Show)  instance HasRange Attribute where@@ -35,6 +37,7 @@     QuantityAttribute q  -> getRange q     CohesionAttribute c  -> getRange c     TacticAttribute e    -> getRange e+    LockAttribute l      -> NoRange  instance SetRange Attribute where   setRange r = \case@@ -42,6 +45,7 @@     QuantityAttribute q  -> QuantityAttribute  $ setRange r q     CohesionAttribute c  -> CohesionAttribute  $ setRange r c     TacticAttribute e    -> TacticAttribute e  -- -- $ setRange r e -- SetRange Expr not yet implemented+    LockAttribute l      -> LockAttribute l  instance KillRange Attribute where   killRange = \case@@ -49,10 +53,11 @@     QuantityAttribute q  -> QuantityAttribute  $ killRange q     CohesionAttribute c  -> CohesionAttribute  $ killRange c     TacticAttribute e    -> TacticAttribute    $ killRange e+    LockAttribute l      -> LockAttribute l  -- | (Conjunctive constraint.) -type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a)+type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensLock a)  -- | Modifiers for 'Relevance'. @@ -88,6 +93,15 @@   , ("flat" , Flat)   ] +-- | Modifiers for 'Quantity'.++lockAttributeTable :: [(String, Lock)]+lockAttributeTable = concat+  [ map (, IsNotLock) [ "notlock" ] -- default, shouldn't be used much+  , map (, IsLock) [ "lock", "tick" ] -- 🔓+  ]++ -- | Concrete syntax for all attributes.  attributesMap :: Map String Attribute@@ -95,6 +109,7 @@   [ map (second RelevanceAttribute) relevanceAttributeTable   , map (second QuantityAttribute)  quantityAttributeTable   , map (second CohesionAttribute)  cohesionAttributeTable+  , map (second LockAttribute)      lockAttributeTable   ]  -- | Parsing a string into an attribute.@@ -105,7 +120,7 @@ -- | Parsing an expression into an attribute.  exprToAttribute :: Expr -> Maybe Attribute-exprToAttribute (Paren _ (RawApp _ [Tactic _ t])) = Just $ TacticAttribute t+exprToAttribute (Paren _ (Tactic _ t)) = Just $ TacticAttribute t exprToAttribute e = setRange (getRange e) $ stringToAttribute $ prettyShow e  -- | Setting an attribute (in e.g. an 'Arg').  Overwrites previous value.@@ -115,6 +130,7 @@   RelevanceAttribute r -> setRelevance r   QuantityAttribute  q -> setQuantity  q   CohesionAttribute  c -> setCohesion  c+  LockAttribute      l -> setLock      l   TacticAttribute t    -> id  @@ -150,6 +166,13 @@   | getCohesion a == defaultCohesion = Just $ setCohesion c a   | otherwise = Nothing +-- | Setting 'Lock' if unset.++setPristineLock :: (LensLock a) => Lock -> a -> Maybe a+setPristineLock q a+  | getLock a == defaultLock = Just $ setLock q a+  | otherwise = Nothing+ -- | Setting an unset attribute (to e.g. an 'Arg').  setPristineAttribute :: (LensAttribute a) => Attribute -> a -> Maybe a@@ -157,6 +180,7 @@   RelevanceAttribute r -> setPristineRelevance r   QuantityAttribute  q -> setPristineQuantity  q   CohesionAttribute  c -> setPristineCohesion  c+  LockAttribute      l -> setPristineLock      l   TacticAttribute{}    -> Just  -- | Setting a list of unset attributes.

src/full/Agda/Syntax/Concrete/Definitions.hs view

@@ -1,1917 +1,1430 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.------   * Attach fixity and syntax declarations to the definition they refer to.------   * Distribute the following attributes to the individual definitions:---       @abstract@,---       @instance@,---       @postulate@,---       @primitive@,---       @private@,---       termination pragmas.------   * Gather the function clauses belonging to one function definition.------   * Expand ellipsis @...@ in function clauses following @with@.------   * Infer mutual blocks.---     A block starts when a lone signature is encountered, and ends when---     all lone signatures have seen their definition.------   * Report basic well-formedness error,---     when one of the above transformation fails.---     When possible, errors should be deferred to the scope checking phase---     (ConcreteToAbstract), where we are in the TCM and can produce more---     informative error messages.---module Agda.Syntax.Concrete.Definitions-    ( NiceDeclaration(..)-    , NiceConstructor, NiceTypeSignature-    , Clause(..)-    , DeclarationException(..)-    , DeclarationWarning(..), unsafeDeclarationWarning-    , Nice, runNice-    , niceDeclarations-    , notSoNiceDeclarations-    , niceHasAbstract-    , Measure-    , declarationWarningName-    ) where--import Prelude hiding (null)--import Control.Arrow ((&&&), (***), second)-import Control.Monad.Except-import Control.Monad.State--import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe-import qualified Data.List as List-import qualified Data.Foldable as Fold-import Data.Traversable (Traversable, traverse)-import qualified Data.Traversable as Trav--import Data.Data (Data)--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.Interaction.Options.Warnings--import Agda.Utils.AffineHole-import Agda.Utils.Except ( MonadError(throwError) )-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List (isSublistOf)-import Agda.Utils.Maybe-import Agda.Utils.Null-import qualified Agda.Utils.Pretty as Pretty-import Agda.Utils.Pretty-import Agda.Utils.Singleton-import Agda.Utils.Three-import Agda.Utils.Tuple-import Agda.Utils.Update--import Agda.Utils.Impossible--{---------------------------------------------------------------------------    Types- --------------------------------------------------------------------------}--{-| The nice declarations. No fixity declarations and function definitions are-    contained in a single constructor instead of spread out between type-    signatures and clauses. The @private@, @postulate@, @abstract@ and @instance@-    modifiers have been distributed to the individual declarations.--    Observe the order of components:--      Range-      Fixity'-      Access-      IsAbstract-      IsInstance-      TerminationCheck-      PositivityCheck--      further attributes--      (Q)Name--      content (Expr, Declaration ...)--}-data NiceDeclaration-  = Axiom Range Access IsAbstract IsInstance ArgInfo Name Expr-      -- ^ 'IsAbstract' argument: We record whether a declaration was made in an @abstract@ block.-      ---      --   'ArgInfo' argument: Axioms and functions can be declared irrelevant.-      --   ('Hiding' should be 'NotHidden'.)-  | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr)-  | PrimitiveFunction Range Access IsAbstract Name Expr-  | NiceMutual Range TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration]-  | NiceModule Range Access IsAbstract QName Telescope [Declaration]-  | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective-  | NiceOpen Range QName ImportDirective-  | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective-  | NicePragma Range Pragma-  | NiceRecSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] Expr-  | NiceDataSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] 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]-      -- ^ 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]-  | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name (Maybe (Ranged Induction)) (Maybe HasEta)-           (Maybe (Name, IsInstance)) [LamBinding] [Declaration]-  | NicePatternSyn Range Access Name [Arg Name] Pattern-  | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr-  | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr-  | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr-  deriving (Data, Show)--type TerminationCheck = Common.TerminationCheck Measure---- | Termination measure is, for now, a variable name.-type Measure = Name--type Catchall = Bool---- | Only 'Axiom's.-type NiceConstructor = NiceTypeSignature---- | Only 'Axiom's.-type NiceTypeSignature  = NiceDeclaration---- | One clause in a function definition. There is no guarantee that the 'LHS'---   actually declares the 'Name'. We will have to check that later.-data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]-    deriving (Data, Show)---- | The exception type.-data DeclarationException-        = MultipleEllipses Pattern-        | InvalidName Name-        | DuplicateDefinition Name-        | MissingWithClauses Name LHS-        | WrongDefinition Name DataRecOrFun DataRecOrFun-        | DeclarationPanic String-        | WrongContentBlock KindOfBlock Range-        | AmbiguousFunClauses LHS [Name] -- ^ in a mutual block, a clause could belong to any of the @[Name]@ type signatures-        | InvalidMeasureMutual Range-          -- ^ In a mutual block, all or none need a MEASURE pragma.-          --   Range is of mutual block.-        | UnquoteDefRequiresSignature [Name]-        | BadMacroDef NiceDeclaration-    deriving (Data, Show)----- | Non-fatal errors encountered in the Nicifier.-data DeclarationWarning-  -- Please keep in alphabetical order.-  = EmptyAbstract Range   -- ^ Empty @abstract@  block.-  | EmptyField Range      -- ^ Empty @field@     block.-  | EmptyGeneralize Range -- ^ Empty @variable@  block.-  | EmptyInstance Range   -- ^ Empty @instance@  block-  | EmptyMacro Range      -- ^ Empty @macro@     block.-  | EmptyMutual Range     -- ^ Empty @mutual@    block.-  | EmptyPostulate Range  -- ^ Empty @postulate@ block.-  | EmptyPrivate Range    -- ^ Empty @private@   block.-  | EmptyPrimitive Range  -- ^ Empty @primitive@ block.-  | InvalidCatchallPragma Range-      -- ^ A {-\# CATCHALL \#-} pragma-      --   that does not precede a function clause.-  | InvalidCoverageCheckPragma Range-      -- ^ A {-\# NON_COVERING \#-} pragma that does not apply to any function.-  | InvalidNoPositivityCheckPragma Range-      -- ^ A {-\# NO_POSITIVITY_CHECK \#-} pragma-      --   that does not apply to any data or record type.-  | InvalidNoUniverseCheckPragma Range-      -- ^ A {-\# NO_UNIVERSE_CHECK \#-} pragma-      --   that does not apply to a data or record type.-  | InvalidTerminationCheckPragma Range-      -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma-      --   that does not apply to any function.-  | MissingDefinitions [(Name, Range)]-      -- ^ Declarations (e.g. type signatures) without a definition.-  | NotAllowedInMutual Range String-  | OpenPublicPrivate Range-      -- ^ @private@ has no effect on @open public@.  (But the user might think so.)-  | OpenPublicAbstract Range-      -- ^ @abstract@ has no effect on @open public@.  (But the user might think so.)-  | PolarityPragmasButNotPostulates [Name]-  | PragmaNoTerminationCheck Range-  -- ^ Pragma @{-\# NO_TERMINATION_CHECK \#-}@ has been replaced-  --   by @{-\# TERMINATING \#-}@ and @{-\# NON_TERMINATING \#-}@.-  | PragmaCompiled Range-  -- ^ @COMPILE@ pragmas are not allowed in safe mode-  | ShadowingInTelescope [(Name, [Range])]-  | UnknownFixityInMixfixDecl [Name]-  | UnknownNamesInFixityDecl [Name]-  | UnknownNamesInPolarityPragmas [Name]-  | UselessAbstract Range-      -- ^ @abstract@ block with nothing that can (newly) be made abstract.-  | UselessInstance Range-      -- ^ @instance@ block with nothing that can (newly) become an instance.-  | UselessPrivate Range-      -- ^ @private@ block with nothing that can (newly) be made private.-  deriving (Data, Show)--declarationWarningName :: DeclarationWarning -> WarningName-declarationWarningName = \case-  -- Please keep in alphabetical order.-  EmptyAbstract{}                   -> EmptyAbstract_-  EmptyField{}                      -> EmptyField_-  EmptyGeneralize{}                 -> EmptyGeneralize_-  EmptyInstance{}                   -> EmptyInstance_-  EmptyMacro{}                      -> EmptyMacro_-  EmptyMutual{}                     -> EmptyMutual_-  EmptyPrivate{}                    -> EmptyPrivate_-  EmptyPostulate{}                  -> EmptyPostulate_-  EmptyPrimitive{}                  -> EmptyPrimitive_-  InvalidCatchallPragma{}           -> InvalidCatchallPragma_-  InvalidNoPositivityCheckPragma{}  -> InvalidNoPositivityCheckPragma_-  InvalidNoUniverseCheckPragma{}    -> InvalidNoUniverseCheckPragma_-  InvalidTerminationCheckPragma{}   -> InvalidTerminationCheckPragma_-  InvalidCoverageCheckPragma{}      -> InvalidCoverageCheckPragma_-  MissingDefinitions{}              -> MissingDefinitions_-  NotAllowedInMutual{}              -> NotAllowedInMutual_-  OpenPublicPrivate{}               -> OpenPublicPrivate_-  OpenPublicAbstract{}              -> OpenPublicAbstract_-  PolarityPragmasButNotPostulates{} -> PolarityPragmasButNotPostulates_-  PragmaNoTerminationCheck{}        -> PragmaNoTerminationCheck_-  PragmaCompiled{}                  -> PragmaCompiled_-  ShadowingInTelescope{}            -> ShadowingInTelescope_-  UnknownFixityInMixfixDecl{}       -> UnknownFixityInMixfixDecl_-  UnknownNamesInFixityDecl{}        -> UnknownNamesInFixityDecl_-  UnknownNamesInPolarityPragmas{}   -> UnknownNamesInPolarityPragmas_-  UselessAbstract{}                 -> UselessAbstract_-  UselessInstance{}                 -> UselessInstance_-  UselessPrivate{}                  -> UselessPrivate_---- | Nicifier warnings turned into errors in @--safe@ mode.-unsafeDeclarationWarning :: DeclarationWarning -> Bool-unsafeDeclarationWarning = \case-  -- Please keep in alphabetical order.-  EmptyAbstract{}                   -> False-  EmptyField{}                      -> False-  EmptyGeneralize{}                 -> False-  EmptyInstance{}                   -> False-  EmptyMacro{}                      -> False-  EmptyMutual{}                     -> False-  EmptyPrivate{}                    -> False-  EmptyPostulate{}                  -> False-  EmptyPrimitive{}                  -> False-  InvalidCatchallPragma{}           -> False-  InvalidNoPositivityCheckPragma{}  -> False-  InvalidNoUniverseCheckPragma{}    -> False-  InvalidTerminationCheckPragma{}   -> False-  InvalidCoverageCheckPragma{}      -> False-  MissingDefinitions{}              -> True  -- not safe-  NotAllowedInMutual{}              -> False -- really safe?-  OpenPublicPrivate{}               -> False-  OpenPublicAbstract{}              -> False-  PolarityPragmasButNotPostulates{} -> False-  PragmaNoTerminationCheck{}        -> True  -- not safe-  PragmaCompiled{}                  -> True  -- not safe-  ShadowingInTelescope{}            -> False-  UnknownFixityInMixfixDecl{}       -> False-  UnknownNamesInFixityDecl{}        -> False-  UnknownNamesInPolarityPragmas{}   -> False-  UselessAbstract{}                 -> False-  UselessInstance{}                 -> False-  UselessPrivate{}                  -> False---- | 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).-  deriving (Data, Eq, Ord, Show)---instance HasRange DeclarationException where-  getRange (MultipleEllipses d)                 = getRange d-  getRange (InvalidName x)                      = getRange x-  getRange (DuplicateDefinition x)              = getRange x-  getRange (MissingWithClauses x lhs)           = getRange lhs-  getRange (WrongDefinition x k k')             = getRange x-  getRange (AmbiguousFunClauses lhs xs)         = getRange lhs-  getRange (DeclarationPanic _)                 = noRange-  getRange (WrongContentBlock _ r)              = r-  getRange (InvalidMeasureMutual r)             = r-  getRange (UnquoteDefRequiresSignature x)      = getRange x-  getRange (BadMacroDef d)                      = getRange d--instance HasRange DeclarationWarning where-  getRange (UnknownNamesInFixityDecl xs)        = getRange xs-  getRange (UnknownFixityInMixfixDecl xs)       = getRange xs-  getRange (UnknownNamesInPolarityPragmas xs)   = getRange xs-  getRange (PolarityPragmasButNotPostulates xs) = getRange xs-  getRange (MissingDefinitions xs)              = getRange xs-  getRange (UselessPrivate r)                   = r-  getRange (NotAllowedInMutual r x)             = r-  getRange (UselessAbstract r)                  = r-  getRange (UselessInstance r)                  = r-  getRange (EmptyMutual r)                      = r-  getRange (EmptyAbstract r)                    = r-  getRange (EmptyPrivate r)                     = r-  getRange (EmptyInstance r)                    = r-  getRange (EmptyMacro r)                       = r-  getRange (EmptyPostulate r)                   = r-  getRange (EmptyGeneralize r)                  = r-  getRange (EmptyPrimitive r)                   = r-  getRange (EmptyField r)                       = r-  getRange (InvalidTerminationCheckPragma r)    = r-  getRange (InvalidCoverageCheckPragma r)       = r-  getRange (InvalidNoPositivityCheckPragma r)   = r-  getRange (InvalidCatchallPragma r)            = r-  getRange (InvalidNoUniverseCheckPragma r)     = r-  getRange (PragmaNoTerminationCheck r)         = r-  getRange (PragmaCompiled r)                   = r-  getRange (OpenPublicAbstract r)               = r-  getRange (OpenPublicPrivate r)                = r-  getRange (ShadowingInTelescope ns)            = getRange ns--instance HasRange NiceDeclaration where-  getRange (Axiom r _ _ _ _ _ _)           = r-  getRange (NiceField r _ _ _ _ _ _)       = r-  getRange (NiceMutual r _ _ _ _)          = r-  getRange (NiceModule r _ _ _ _ _ )       = r-  getRange (NiceModuleMacro r _ _ _ _ _)   = r-  getRange (NiceOpen r _ _)                = r-  getRange (NiceImport r _ _ _ _)          = r-  getRange (NicePragma r _)                = r-  getRange (PrimitiveFunction r _ _ _ _)   = r-  getRange (FunSig r _ _ _ _ _ _ _ _ _)    = r-  getRange (FunDef r _ _ _ _ _ _ _)        = r-  getRange (NiceDataDef r _ _ _ _ _ _ _)   = r-  getRange (NiceRecDef r _ _ _ _ _ _ _ _ _ _)  = r-  getRange (NiceRecSig r _ _ _ _ _ _ _)    = r-  getRange (NiceDataSig r _ _ _ _ _ _ _)   = r-  getRange (NicePatternSyn r _ _ _ _)      = r-  getRange (NiceGeneralize r _ _ _ _ _)    = r-  getRange (NiceFunClause r _ _ _ _ _ _)   = r-  getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r-  getRange (NiceUnquoteDef r _ _ _ _ _ _)    = r--instance Pretty NiceDeclaration where-  pretty = \case-    Axiom _ _ _ _ _ x _            -> text "postulate" <+> pretty x <+> colon <+> text "_"-    NiceField _ _ _ _ _ x _        -> text "field" <+> pretty x-    PrimitiveFunction _ _ _ x _    -> text "primitive" <+> pretty x-    NiceMutual{}                   -> text "mutual"-    NiceModule _ _ _ x _ _         -> text "module" <+> pretty x <+> text "where"-    NiceModuleMacro _ _ x _ _ _    -> text "module" <+> pretty x <+> text "= ..."-    NiceOpen _ x _                 -> text "open" <+> pretty x-    NiceImport _ x _ _ _           -> text "import" <+> pretty x-    NicePragma{}                   -> text "{-# ... #-}"-    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"-    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>"---- These error messages can (should) be terminated by a dot ".",--- there is no error context printed after them.-instance Pretty DeclarationException where-  pretty (MultipleEllipses p) = fsep $-    pwords "Multiple ellipses in left-hand side" ++ [pretty p]-  pretty (InvalidName x) = fsep $-    pwords "Invalid name:" ++ [pretty x]-  pretty (DuplicateDefinition x) = fsep $-    pwords "Duplicate definition of" ++ [pretty x]-  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 " ++ show k ++-      ", but is being defined as a " ++ show 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 $ map (pretty . PrintRange) xs-    ]-  pretty (WrongContentBlock b _)      = fsep . pwords $-    case b of-      PostulateBlock -> "A postulate block can only contain type signatures, possibly under keyword instance"-      DataBlock -> "A data definition can only contain type signatures, possibly under keyword instance"-      _ -> "Unexpected declaration"-  pretty (InvalidMeasureMutual _) = fsep $-    pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma."-  pretty (UnquoteDefRequiresSignature xs) = fsep $-    pwords "Missing type signatures for unquoteDef" ++ map pretty xs-  pretty (BadMacroDef nd) = fsep $-    [text $ declName nd] ++ pwords "are not allowed in macro blocks"-  pretty (DeclarationPanic s) = text s--instance Pretty DeclarationWarning where-  pretty (UnknownNamesInFixityDecl xs) = fsep $-    pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):"-    ++ punctuate comma (map pretty xs)-  pretty (UnknownFixityInMixfixDecl xs) = fsep $-    pwords "The following mixfix names do not have an associated fixity declaration:"-    ++ punctuate comma (map pretty xs)-  pretty (UnknownNamesInPolarityPragmas xs) = fsep $-    pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):"-    ++ punctuate comma  (map pretty xs)-  pretty (MissingDefinitions xs) = fsep $-   pwords "The following names are declared but not accompanied by a definition:"-   ++ punctuate comma (map (pretty . fst) xs)-  pretty (NotAllowedInMutual r nd) = fsep $-    [text nd] ++ pwords "in mutual blocks are not supported.  Suggestion: get rid of the mutual block by manually ordering declarations"-  pretty (PolarityPragmasButNotPostulates xs) = fsep $-    pwords "Polarity pragmas have been given for the following identifiers which are not postulates:"-    ++ punctuate comma (map pretty xs)-  pretty (UselessPrivate _)      = fsep $-    pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."-  pretty (UselessAbstract _)      = fsep $-    pwords "Using abstract here has no effect. Abstract applies to only definitions like data definitions, record type definitions and function clauses."-  pretty (UselessInstance _)      = fsep $-    pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."-  pretty (EmptyMutual    _)  = fsep $ pwords "Empty mutual block."-  pretty (EmptyAbstract  _)  = fsep $ pwords "Empty abstract block."-  pretty (EmptyPrivate   _)  = fsep $ pwords "Empty private block."-  pretty (EmptyInstance  _)  = fsep $ pwords "Empty instance block."-  pretty (EmptyMacro     _)  = fsep $ pwords "Empty macro block."-  pretty (EmptyPostulate _)  = fsep $ pwords "Empty postulate block."-  pretty (EmptyGeneralize _) = fsep $ pwords "Empty variable block."-  pretty (EmptyPrimitive _)  = fsep $ pwords "Empty primitive block."-  pretty (EmptyField _)      = fsep $ pwords "Empty field block."-  pretty (InvalidTerminationCheckPragma _) = fsep $-    pwords "Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."-  pretty (InvalidCoverageCheckPragma _)    = fsep $-    pwords "Coverage checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."-  pretty (InvalidNoPositivityCheckPragma _) = fsep $-    pwords "NO_POSITIVITY_CHECKING pragmas can only precede a data/record definition or a mutual block (that contains a data/record definition)."-  pretty (InvalidCatchallPragma _) = fsep $-    pwords "The CATCHALL pragma can only precede a function clause."-  pretty (InvalidNoUniverseCheckPragma _) = fsep $-    pwords "NO_UNIVERSE_CHECKING pragmas can only precede a data/record definition."-  pretty (PragmaNoTerminationCheck _) = fsep $-    pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed.  To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."-  pretty (PragmaCompiled _) = fsep $-    pwords "COMPILE pragma not allowed in safe mode."-  pretty (OpenPublicAbstract _) = fsep $-    pwords "public does not have any effect in an abstract block."-  pretty (OpenPublicPrivate _) = fsep $-    pwords "public does not have any effect in a private block."-  pretty (ShadowingInTelescope nrs) = fsep $-    pwords "Shadowing in telescope, repeated variable names:"-    ++ punctuate comma (map (pretty . fst) nrs)--declName :: NiceDeclaration -> String-declName Axiom{}             = "Postulates"-declName NiceField{}         = "Fields"-declName NiceMutual{}        = "Mutual blocks"-declName NiceModule{}        = "Modules"-declName NiceModuleMacro{}   = "Modules"-declName NiceOpen{}          = "Open declarations"-declName NiceImport{}        = "Import statements"-declName NicePragma{}        = "Pragmas"-declName PrimitiveFunction{} = "Primitive declarations"-declName NicePatternSyn{}    = "Pattern synonyms"-declName NiceGeneralize{}    = "Generalized variables"-declName NiceUnquoteDecl{}   = "Unquoted declarations"-declName NiceUnquoteDef{}    = "Unquoted definitions"-declName NiceRecSig{}        = "Records"-declName NiceDataSig{}       = "Data types"-declName NiceFunClause{}     = "Functions without a type signature"-declName FunSig{}            = "Type signatures"-declName FunDef{}            = "Function definitions"-declName NiceRecDef{}            = "Records"-declName NiceDataDef{}       = "Data types"--{---------------------------------------------------------------------------    The niceifier- --------------------------------------------------------------------------}--data InMutual-  = InMutual    -- ^ we are nicifying a mutual block-  | NotInMutual -- ^ we are nicifying decls not in a mutual block-    deriving (Eq, Show)---- | The kind of the forward declaration.--data DataRecOrFun-  = DataName-    { _kindPosCheck :: PositivityCheck-    , _kindUniCheck :: UniverseCheck-    }-    -- ^ Name of a data type-  | RecName-    { _kindPosCheck :: PositivityCheck-    , _kindUniCheck :: UniverseCheck-    }-    -- ^ Name of a record type-  | FunName TerminationCheck CoverageCheck-    -- ^ Name of a function.-  deriving Data---- Ignore pragmas when checking equality-instance Eq DataRecOrFun where-  DataName{} == DataName{} = True-  RecName{}  == RecName{}  = True-  FunName{}  == FunName{}  = True-  _          == _          = False--instance Show DataRecOrFun where-  show DataName{} = "data type"-  show RecName{}  = "record type"-  show FunName{}  = "function"--isFunName :: DataRecOrFun -> Bool-isFunName (FunName{}) = True-isFunName _           = False--sameKind :: DataRecOrFun -> DataRecOrFun -> Bool-sameKind = (==)--terminationCheck :: DataRecOrFun -> TerminationCheck-terminationCheck (FunName tc _) = tc-terminationCheck _ = TerminationCheck--coverageCheck :: DataRecOrFun -> CoverageCheck-coverageCheck (FunName _ cc) = cc-coverageCheck _ = YesCoverageCheck--positivityCheck :: DataRecOrFun -> PositivityCheck-positivityCheck (DataName pc _) = pc-positivityCheck (RecName pc _)  = pc-positivityCheck _               = YesPositivityCheck--universeCheck :: DataRecOrFun -> UniverseCheck-universeCheck (DataName _ uc) = uc-universeCheck (RecName _ uc)  = uc-universeCheck _               = YesUniverseCheck---- | Check that declarations in a mutual block are consistently---   equipped with MEASURE pragmas, or whether there is a---   NO_TERMINATION_CHECK pragma.-combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck-combineTerminationChecks r tcs = loop tcs where-  loop :: [TerminationCheck] -> Nice TerminationCheck-  loop []         = return TerminationCheck-  loop (tc : tcs) = do-    let failure r = throwError $ InvalidMeasureMutual r-    tc' <- loop tcs-    case (tc, tc') of-      (TerminationCheck      , tc'                   ) -> return tc'-      (tc                    , TerminationCheck      ) -> return tc-      (NonTerminating        , NonTerminating        ) -> return NonTerminating-      (NoTerminationCheck    , NoTerminationCheck    ) -> return NoTerminationCheck-      (NoTerminationCheck    , Terminating           ) -> return Terminating-      (Terminating           , NoTerminationCheck    ) -> return Terminating-      (Terminating           , Terminating           ) -> return Terminating-      (TerminationMeasure{}  , TerminationMeasure{}  ) -> return tc-      (TerminationMeasure r _, NoTerminationCheck    ) -> failure r-      (TerminationMeasure r _, Terminating           ) -> failure r-      (NoTerminationCheck    , TerminationMeasure r _) -> failure r-      (Terminating           , TerminationMeasure r _) -> failure r-      (TerminationMeasure r _, NonTerminating        ) -> failure r-      (NonTerminating        , TerminationMeasure r _) -> failure r-      (NoTerminationCheck    , NonTerminating        ) -> failure r-      (Terminating           , NonTerminating        ) -> failure r-      (NonTerminating        , NoTerminationCheck    ) -> failure r-      (NonTerminating        , Terminating           ) -> failure r--combineCoverageChecks :: [CoverageCheck] -> CoverageCheck-combineCoverageChecks = Fold.fold--combinePositivityChecks :: [PositivityCheck] -> PositivityCheck-combinePositivityChecks = Fold.fold---- | Nicifier monad.---   Preserve the state when throwing an exception.--newtype Nice a = Nice { unNice :: ExceptT DeclarationException (State NiceEnv) a }-  deriving ( Functor, Applicative, Monad-           , MonadState NiceEnv, MonadError DeclarationException-           )---- | Run a Nicifier computation, return result and warnings---   (in chronological order).-runNice :: Nice a -> (Either DeclarationException a, NiceWarnings)-runNice m = second (reverse . niceWarn) $-  runExceptT (unNice m) `runState` initNiceEnv---- | Nicifier state.--data NiceEnv = NiceEnv-  { _loneSigs :: LoneSigs-    -- ^ Lone type signatures that wait for their definition.-  , _termChk  :: TerminationCheck-    -- ^ Termination checking pragma waiting for a definition.-  , _posChk   :: PositivityCheck-    -- ^ Positivity checking pragma waiting for a definition.-  , _uniChk   :: UniverseCheck-    -- ^ Universe checking pragma waiting for a data/rec signature or definition.-  , _catchall :: Catchall-    -- ^ Catchall pragma waiting for a function clause.-  , _covChk  :: CoverageCheck-    -- ^ Coverage pragma waiting for a definition.-  , niceWarn :: NiceWarnings-    -- ^ Stack of warnings. Head is last warning.-  }--data LoneSig = LoneSig-  { loneSigRange :: Range-  , loneSigName  :: Name-  , loneSigKind  :: DataRecOrFun-  }--type LoneSigs     = Map Name LoneSig-     -- ^ We retain the 'Name' also in the codomain since-     --   'Name' as a key is up to @Eq Name@ which ignores the range.-     --   However, without range names are not unique in case the-     --   user gives a second definition of the same name.-     --   This causes then problems in 'replaceSigs' which might-     --   replace the wrong signature.-type NiceWarnings = [DeclarationWarning]-     -- ^ Stack of warnings. Head is last warning.---- | Initial nicifier state.--initNiceEnv :: NiceEnv-initNiceEnv = NiceEnv-  { _loneSigs = empty-  , _termChk  = TerminationCheck-  , _posChk   = YesPositivityCheck-  , _uniChk   = YesUniverseCheck-  , _catchall = False-  , _covChk   = YesCoverageCheck-  , niceWarn  = []-  }---- * Handling the lone signatures, stored to infer mutual blocks.---- | Lens for field '_loneSigs'.--loneSigs :: Lens' LoneSigs NiceEnv-loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }---- | Adding a lone signature to the state.--addLoneSig :: Range -> Name -> DataRecOrFun -> Nice ()-addLoneSig r x k = loneSigs %== \ s -> do-   let (mr, s') = Map.insertLookupWithKey (\ _k new _old -> new) x (LoneSig r x k) s-   case mr of-     Nothing -> return s'-     Just{}  -> throwError $ DuplicateDefinition x---- | Remove a lone signature from the state.--removeLoneSig :: Name -> Nice ()-removeLoneSig x = loneSigs %= Map.delete x---- | Search for forward type signature.--getSig :: Name -> Nice (Maybe DataRecOrFun)-getSig x = fmap loneSigKind . Map.lookup x <$> use loneSigs---- | Check that no lone signatures are left in the state.--noLoneSigs :: Nice Bool-noLoneSigs = null <$> use loneSigs---- | Ensure that all forward declarations have been given a definition.--forgetLoneSigs :: Nice ()-forgetLoneSigs = loneSigs .= Map.empty--checkLoneSigs :: LoneSigs -> Nice ()-checkLoneSigs xs = do-  forgetLoneSigs-  unless (Map.null xs) $ niceWarning $ MissingDefinitions $-    map (\s -> (loneSigName s , loneSigRange s)) $ Map.elems xs---- | Get names of lone function signatures.--loneFuns :: LoneSigs -> [Name]-loneFuns = map fst . filter (isFunName . loneSigKind . snd) . Map.toList---- | Create a 'LoneSigs' map from an association list.--loneSigsFromLoneNames :: [(Range, Name, DataRecOrFun)] -> LoneSigs-loneSigsFromLoneNames = Map.fromList . map (\(r,x,k) -> (x, LoneSig r x k))---- | Lens for field '_termChk'.--terminationCheckPragma :: Lens' TerminationCheck NiceEnv-terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }--withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a-withTerminationCheckPragma tc f = do-  tc_old <- use terminationCheckPragma-  terminationCheckPragma .= tc-  result <- f-  terminationCheckPragma .= tc_old-  return result--coverageCheckPragma :: Lens' CoverageCheck NiceEnv-coverageCheckPragma f e = f (_covChk e) <&> \ s -> e { _covChk = s }--withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a-withCoverageCheckPragma tc f = do-  tc_old <- use coverageCheckPragma-  coverageCheckPragma .= tc-  result <- f-  coverageCheckPragma .= tc_old-  return result---- | Lens for field '_posChk'.--positivityCheckPragma :: Lens' PositivityCheck NiceEnv-positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }--withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a-withPositivityCheckPragma pc f = do-  pc_old <- use positivityCheckPragma-  positivityCheckPragma .= pc-  result <- f-  positivityCheckPragma .= pc_old-  return result---- | Lens for field '_uniChk'.--universeCheckPragma :: Lens' UniverseCheck NiceEnv-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'.--getUniverseCheckFromSig :: Name -> Nice UniverseCheck-getUniverseCheckFromSig x = maybe YesUniverseCheck universeCheck <$> getSig x---- | Lens for field '_catchall'.--catchallPragma :: Lens' Catchall NiceEnv-catchallPragma f e = f (_catchall e) <&> \ s -> e { _catchall = s }---- | Get current catchall pragma, and reset it for the next clause.--popCatchallPragma :: Nice Catchall-popCatchallPragma = do-  ca <- use catchallPragma-  catchallPragma .= False-  return ca--withCatchallPragma :: Catchall -> Nice a -> Nice a-withCatchallPragma ca f = do-  ca_old <- use catchallPragma-  catchallPragma .= ca-  result <- f-  catchallPragma .= ca_old-  return result---- | Add a new warning.-niceWarning :: DeclarationWarning -> Nice ()-niceWarning w = modify $ \ st -> st { niceWarn = w : niceWarn st }--data DeclKind-    = LoneSigDecl Range DataRecOrFun Name-    | LoneDefs DataRecOrFun [Name]-    | OtherDecl-  deriving (Eq, Show)--declKind :: NiceDeclaration -> DeclKind-declKind (FunSig r _ _ _ _ _ tc cc x _)     = LoneSigDecl r (FunName tc cc) x-declKind (NiceRecSig r _ _ pc uc x pars _)  = LoneSigDecl r (RecName pc uc) x-declKind (NiceDataSig r _ _ pc uc x pars _) = LoneSigDecl r (DataName pc uc) x-declKind (FunDef r _ abs ins tc cc x _)     = LoneDefs (FunName tc cc) [x]-declKind (NiceDataDef _ _ _ pc uc x pars _) = LoneDefs (DataName pc uc) [x]-declKind (NiceRecDef _ _ _ pc uc x _ _ _ pars _)= LoneDefs (RecName pc uc) [x]-declKind (NiceUnquoteDef _ _ _ tc cc xs _)  = LoneDefs (FunName tc cc) xs-declKind Axiom{}                            = OtherDecl-declKind NiceField{}                        = OtherDecl-declKind PrimitiveFunction{}                = OtherDecl-declKind NiceMutual{}                       = OtherDecl-declKind NiceModule{}                       = OtherDecl-declKind NiceModuleMacro{}                  = OtherDecl-declKind NiceOpen{}                         = OtherDecl-declKind NiceImport{}                       = OtherDecl-declKind NicePragma{}                       = OtherDecl-declKind NiceFunClause{}                    = OtherDecl-declKind NicePatternSyn{}                   = OtherDecl-declKind NiceGeneralize{}                   = OtherDecl-declKind NiceUnquoteDecl{}                  = OtherDecl---- | Replace (Data/Rec/Fun)Sigs with Axioms 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-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-      Just (x, axiom)-        | (Just (LoneSig _ x' _), ps') <- Map.updateLookupWithKey (\ _ _ -> Nothing) x ps-        , getRange x == getRange x'-            -- Use the range as UID to ensure we do not replace the wrong signature.-            -- This could happen if the user wrote a duplicate definition.-        -> axiom : replaceSigs ps' ds-      _ -> d     : replaceSigs ps  ds--  where--    -- A @replaceable@ declaration is a signature. It has a name and we can make an-    -- @Axiom@ out of it.-    replaceable :: NiceDeclaration -> Maybe (Name, NiceDeclaration)-    replaceable = \case-      FunSig r acc abst inst _ argi _ _ x e ->-        Just (x, Axiom r acc abst inst argi x e)-      NiceRecSig r acc abst _ _ x pars t ->-        let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in-        Just (x, Axiom r acc abst NotInstanceDef defaultArgInfo x e)-      NiceDataSig r acc abst _ _ x pars t ->-        let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in-        Just (x, Axiom r acc abst NotInstanceDef defaultArgInfo x e)-      _ -> Nothing---- | Main. Fixities (or more precisely syntax declarations) are needed when---   grouping function clauses.-niceDeclarations :: Fixities -> [Declaration] -> Nice [NiceDeclaration]-niceDeclarations fixs ds = do--  -- Run the nicifier in an initial environment. But keep the warnings.-  st <- get-  put $ initNiceEnv { niceWarn = niceWarn st }-  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--  -- Note that loneSigs is ensured to be empty.-  -- (Important, since inferMutualBlocks also uses loneSigs state).-  res <- inferMutualBlocks ds--  -- Restore the old state, but keep the warnings.-  warns <- gets niceWarn-  put $ st { niceWarn = warns }-  return res--  where--    inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]-    inferMutualBlocks [] = return []-    inferMutualBlocks (d : ds) =-      case declKind d of-        OtherDecl    -> (d :) <$> inferMutualBlocks ds-        LoneDefs{}   -> (d :) <$> inferMutualBlocks ds  -- Andreas, 2017-10-09, issue #2576: report error in ConcreteToAbstract-        LoneSigDecl r k x  -> do-          addLoneSig r x k-          let tcccpc = ([terminationCheck k], [coverageCheck k], [positivityCheck k])-          ((tcs, ccs, pcs), (nds0, ds1)) <- untilAllDefined tcccpc 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 then keep processing the rest of the block-          tc <- combineTerminationChecks (getRange d) tcs-          let cc = combineCoverageChecks ccs-          let pc = combinePositivityChecks pcs-          (NiceMutual (getRange ds0) tc cc pc ds0 :) <$> inferMutualBlocks ds1-      where-        untilAllDefined :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])-                        -> [NiceDeclaration]-                        -> Nice (([TerminationCheck], [CoverageCheck], [PositivityCheck]) -- checks for this block-                                , ([NiceDeclaration]                                      -- mutual block-                                , [NiceDeclaration])                                      -- leftovers-                                )-        untilAllDefined tcccpc@(tc, cc, pc) ds = do-          done <- noLoneSigs-          if done then return (tcccpc, ([], ds)) else-            case ds of-              []     -> return (tcccpc, ([], ds))-              d : ds -> case declKind d of-                LoneSigDecl r k x -> do-                  addLoneSig r x k-                  let tcccpc' = (terminationCheck k : tc, coverageCheck k : cc, positivityCheck k : pc)-                  cons d (untilAllDefined tcccpc' ds)-                LoneDefs k xs -> do-                  mapM_ removeLoneSig xs-                  let tcccpc' = (terminationCheck k : tc, coverageCheck k : cc, positivityCheck k : pc)-                  cons d (untilAllDefined tcccpc' ds)-                OtherDecl   -> cons d (untilAllDefined tcccpc ds)-          where-            -- ASR (26 December 2015): Type annotated version of the @cons@ function.-            -- cons d = fmap $-            --            (id :: (([TerminationCheck], [PositivityCheck]) -> ([TerminationCheck], [PositivityCheck])))-            --            *** (d :)-            --            *** (id :: [NiceDeclaration] -> [NiceDeclaration])-            cons d = fmap (id *** (d :) *** id)--    notMeasure TerminationMeasure{} = False-    notMeasure _ = True--    nice :: [Declaration] -> Nice [NiceDeclaration]-    nice [] = return []-    nice ds = do-      (xs , ys) <- nice1 ds-      (xs ++) <$> nice ys--    nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])-    nice1 []     = return ([], []) -- Andreas, 2017-09-16, issue #2759: no longer __IMPOSSIBLE__-    nice1 (d:ds) = do-      let justWarning w = do niceWarning w; nice1 ds--      case d of--        TypeSig info _tac x t -> do-          termCheck <- use terminationCheckPragma-          covCheck  <- use coverageCheckPragma-          let r = getRange d-          -- register x as lone type signature, to recognize clauses later-          addLoneSig r x $ FunName 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-        FieldSig{} -> __IMPOSSIBLE__--        Generalize r [] -> justWarning $ EmptyGeneralize r-        Generalize r sigs -> do-          gs <- forM sigs $ \case-            sig@(TypeSig info tac x t) -> do-              return $ NiceGeneralize (getRange sig) PublicAccess info tac x t-            _ -> __IMPOSSIBLE__-          return (gs, ds)--        (FunClause lhs _ _ _)         -> do-          termCheck <- use terminationCheckPragma-          covCheck  <- use coverageCheckPragma-          catchall  <- popCatchallPragma-          xs <- loneFuns <$> use loneSigs-          -- for each type signature 'x' waiting for clauses, we try-          -- if we have some clauses for 'x'-          case [ (x, (fits, rest))-               | x <- xs-               , let (fits, rest) =-                      -- Anonymous declarations only have 1 clause each!-                      if isNoName x then ([d], ds)-                      else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)-               , not (null fits)-               ] of--            -- case: clauses match none of the sigs-            [] -> case lhs of-              -- Subcase: The lhs is single identifier (potentially anonymous).-              -- Treat it as a function clause without a type signature.-              LHS p [] [] _ | Just x <- isSingleIdentifierP p -> do-                d  <- mkFunDef defaultArgInfo termCheck covCheck x Nothing [d] -- fun def without type signature is relevant-                return (d , ds)-              -- Subcase: The lhs is a proper pattern.-              -- This could be a let-pattern binding. Pass it on.-              -- A missing type signature error might be raise in ConcreteToAbstract-              _ -> do-                return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck covCheck catchall d] , ds)--            -- case: clauses match exactly one of the sigs-            [(x,(fits,rest))] -> do-               removeLoneSig x-               ds  <- expandEllipsis fits-               cs  <- mkClauses x ds False-               return ([FunDef (getRange fits) fits ConcreteDef NotInstanceDef termCheck covCheck x cs] , rest)--            -- case: clauses match more than one sigs (ambiguity)-            l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l-                 -- "ambiguous function clause; cannot assign it uniquely to one type signature"--        Field r [] -> justWarning $ EmptyField r-        Field _ fs -> (,ds) <$> niceAxioms FieldBlock fs--        DataSig r x tel t -> do-          pc <- use positivityCheckPragma-          uc <- use universeCheckPragma-          addLoneSig r x $ DataName pc uc-          (,) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x (Just (tel, t)) Nothing-              <*> return ds--        Data r 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)-          (,) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x ((tel,) <$> mt) (Just (tel, cs))-              <*> return ds--        DataDef r x tel 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 Nothing-          (,) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x ((tel,) <$> mt) (Just (tel, cs))-              <*> return ds--        RecordSig r x tel t         -> do-          pc <- use positivityCheckPragma-          uc <- use universeCheckPragma-          addLoneSig r x $ RecName pc uc-          return ([NiceRecSig r PublicAccess ConcreteDef pc uc x tel t] , ds)--        Record r x i e c 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)-          (,) <$> dataOrRec pc uc (\ r o a pc uc x tel cs -> NiceRecDef r o a pc uc x i e c tel cs) NiceRecSig-                    return r x ((tel,) <$> mt) (Just (tel, cs))-              <*> return ds--        RecordDef r x i e c tel 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 Nothing-          (,) <$> dataOrRec pc uc (\ r o a pc uc x tel cs -> NiceRecDef r o a pc uc x i e c tel cs) NiceRecSig-                    return r x ((tel,) <$> mt) (Just (tel, cs))-              <*> return ds--        Mutual r ds' -> do-          -- The lone signatures encountered so far are not in scope-          -- for the mutual definition-          forgetLoneSigs-          case ds' of-            [] -> justWarning $ EmptyMutual r-            _  -> (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))--        Abstract r []  -> justWarning $ EmptyAbstract r-        Abstract r ds' ->-          (,ds) <$> (abstractBlock r =<< nice ds')--        Private r UserWritten []  -> justWarning $ EmptyPrivate r-        Private r o ds' ->-          (,ds) <$> (privateBlock r o =<< nice ds')--        InstanceB r []  -> justWarning $ EmptyInstance r-        InstanceB r ds' ->-          (,ds) <$> (instanceBlock r =<< nice ds')--        Macro r []  -> justWarning $ EmptyMacro r-        Macro r ds' ->-          (,ds) <$> (macroBlock r =<< nice ds')--        Postulate r []  -> justWarning $ EmptyPostulate r-        Postulate _ ds' ->-          (,ds) <$> niceAxioms PostulateBlock ds'--        Primitive r []  -> justWarning $ EmptyPrimitive r-        Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')--        Module r x tel ds' -> return $-          ([NiceModule r PublicAccess ConcreteDef x tel ds'] , ds)--        ModuleMacro r x modapp op is -> return $-          ([NiceModuleMacro r PublicAccess x modapp op is] , ds)--        -- Fixity and syntax declarations and polarity pragmas have-        -- already been processed.-        Infix _ _  -> return ([], ds)-        Syntax _ _ -> return ([], ds)--        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)--        UnquoteDecl r xs e -> do-          tc <- use terminationCheckPragma-          cc <- use coverageCheckPragma-          return ([NiceUnquoteDecl r PublicAccess ConcreteDef NotInstanceDef tc cc xs e] , ds)--        UnquoteDef r xs e -> do-          sigs <- loneFuns <$> use loneSigs-          let missing = filter (`notElem` sigs) xs-          if null missing-            then do-              mapM_ removeLoneSig xs-              return ([NiceUnquoteDef r PublicAccess ConcreteDef TerminationCheck YesCoverageCheck xs e] , ds)-            else throwError $ UnquoteDefRequiresSignature missing--        Pragma p -> nicePragma p ds--    nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])--    nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =-      if canHaveTerminationMeasure ds then-        withTerminationCheckPragma (TerminationMeasure r x) $ nice1 ds-      else do-        niceWarning $ 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.-      niceWarning $ PragmaNoTerminationCheck r-      nicePragma (TerminationCheckPragma r NonTerminating) ds--    nicePragma (TerminationCheckPragma r tc) ds =-      if canHaveTerminationCheckPragma ds then-        withTerminationCheckPragma tc $ nice1 ds-      else do-        niceWarning $ InvalidTerminationCheckPragma r-        nice1 ds--    nicePragma (NoCoverageCheckPragma r) ds =-      if canHaveCoverageCheckPragma ds then-        withCoverageCheckPragma NoCoverageCheck $ nice1 ds-      else do-        niceWarning $ InvalidCoverageCheckPragma r-        nice1 ds--    nicePragma (CatchallPragma r) ds =-      if canHaveCatchallPragma ds then-        withCatchallPragma True $ nice1 ds-      else do-        niceWarning $ InvalidCatchallPragma r-        nice1 ds--    nicePragma (NoPositivityCheckPragma r) ds =-      if canHaveNoPositivityCheckPragma ds then-        withPositivityCheckPragma NoPositivityCheck $ nice1 ds-      else do-        niceWarning $ InvalidNoPositivityCheckPragma r-        nice1 ds--    nicePragma (NoUniverseCheckPragma r) ds =-      if canHaveNoUniverseCheckPragma ds then-        withUniverseCheckPragma NoUniverseCheck $ nice1 ds-      else do-        niceWarning $ InvalidNoUniverseCheckPragma r-        nice1 ds--    nicePragma p@CompilePragma{} ds = do-      niceWarning $ PragmaCompiled (getRange p)-      return ([NicePragma (getRange p) p], ds)--    nicePragma (PolarityPragma{}) ds = return ([], ds)--    nicePragma (BuiltinPragma r str qn@(QName x)) ds = do-      return ([NicePragma r (BuiltinPragma r str qn)], ds)--    nicePragma p ds = return ([NicePragma (getRange p) p], ds)--    canHaveTerminationMeasure :: [Declaration] -> Bool-    canHaveTerminationMeasure [] = False-    canHaveTerminationMeasure (d:ds) = case d of-      TypeSig{} -> True-      (Pragma p) | isAttachedPragma p -> canHaveTerminationMeasure ds-      _         -> False--    canHaveTerminationCheckPragma :: [Declaration] -> Bool-    canHaveTerminationCheckPragma []     = False-    canHaveTerminationCheckPragma (d:ds) = case d of-      Mutual _ ds   -> any (canHaveTerminationCheckPragma . singleton) ds-      TypeSig{}     -> True-      FunClause{}   -> True-      UnquoteDecl{} -> True-      (Pragma p) | isAttachedPragma p -> canHaveTerminationCheckPragma ds-      _             -> False--    canHaveCoverageCheckPragma :: [Declaration] -> Bool-    canHaveCoverageCheckPragma = canHaveTerminationCheckPragma--    canHaveCatchallPragma :: [Declaration] -> Bool-    canHaveCatchallPragma []     = False-    canHaveCatchallPragma (d:ds) = case d of-      FunClause{} -> True-      (Pragma p) | isAttachedPragma p -> canHaveCatchallPragma ds-      _           -> False--    canHaveNoPositivityCheckPragma :: [Declaration] -> Bool-    canHaveNoPositivityCheckPragma []     = False-    canHaveNoPositivityCheckPragma (d:ds) = case d of-      Mutual _ ds                   -> any (canHaveNoPositivityCheckPragma . singleton) ds-      Data{}                        -> True-      DataSig{}                     -> True-      DataDef{}                     -> True-      Record{}                      -> True-      RecordSig{}                   -> True-      RecordDef{}                   -> True-      Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds-      _                             -> False--    canHaveNoUniverseCheckPragma :: [Declaration] -> Bool-    canHaveNoUniverseCheckPragma []     = False-    canHaveNoUniverseCheckPragma (d:ds) = case d of-      Data{}                        -> True-      DataSig{}                     -> True-      DataDef{}                     -> True-      Record{}                      -> True-      RecordSig{}                   -> True-      RecordDef{}                   -> True-      Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds-      _                             -> False--    -- Pragma that attaches to the following declaration.-    isAttachedPragma :: Pragma -> Bool-    isAttachedPragma p = case p of-      TerminationCheckPragma{}  -> True-      CatchallPragma{}          -> True-      NoPositivityCheckPragma{} -> True-      NoUniverseCheckPragma{}   -> 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') $ throwError $ WrongDefinition x k' k-        Nothing <$ removeLoneSig x--    dataOrRec-      :: forall a decl-      .  PositivityCheck-      -> UniverseCheck-      -> (Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [decl] -> NiceDeclaration)-         -- ^ Construct definition.-      -> (Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> 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.-      -> Nice [NiceDeclaration]-    dataOrRec pc uc mkDef mkSig niceD r x mt mcs = do-      mds <- Trav.forM mcs $ \ (tel, cs) -> (tel,) <$> niceD cs-      -- 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-      -- generalizable variables differ in these cases.-      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-          -- 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).-        ]-      where-        -- | Drop type annotations and lets from bindings.-        dropTypeAndModality :: LamBinding -> [LamBinding]-        dropTypeAndModality (DomainFull (TBind _ xs _)) =-          map (DomainFree . setModality defaultModality) xs-        dropTypeAndModality (DomainFull TLet{}) = []-        dropTypeAndModality (DomainFree x) = [DomainFree $ setModality defaultModality x]--    -- Translate axioms-    niceAxioms :: KindOfBlock -> [TypeSignatureOrInstanceBlock] -> Nice [NiceDeclaration]-    niceAxioms b ds = liftM List.concat $ mapM (niceAxiom b) ds--    niceAxiom :: KindOfBlock -> TypeSignatureOrInstanceBlock -> Nice [NiceDeclaration]-    niceAxiom b d = case d of-      TypeSig rel _tac x t -> do-        return [ Axiom (getRange d) PublicAccess ConcreteDef NotInstanceDef rel x t ]-      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-      Pragma p@(RewritePragma r _ _) -> do-        return [ NicePragma r p ]-      _ -> throwError $ WrongContentBlock b $ getRange d--    toPrim :: NiceDeclaration -> NiceDeclaration-    toPrim (Axiom r p a i rel x t) = PrimitiveFunction r p a x t-    toPrim _                       = __IMPOSSIBLE__--    -- Create a function definition.-    mkFunDef info termCheck covCheck x mt ds0 = do-      ds <- expandEllipsis ds0-      cs <- mkClauses x ds False-      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-          t = case mt of-                Just t  -> t-                Nothing -> underscore (getRange x)--    underscore r = Underscore r Nothing---    expandEllipsis :: [Declaration] -> Nice [Declaration]-    expandEllipsis [] = return []-    expandEllipsis (d@(FunClause lhs@(LHS p _ _ ell) _ _ _) : ds)-      | ExpandedEllipsis{} <- ell = __IMPOSSIBLE__-      | hasEllipsis p = (d :) <$> expandEllipsis ds-      | otherwise     = (d :) <$> expand (killRange p) ds-      where-        expand :: Pattern -> [Declaration] -> Nice [Declaration]-        expand _ [] = return []-        expand p (d : ds) = do-          case d of-            Pragma (CatchallPragma _) -> do-                  (d :) <$> expand p ds-            FunClause (LHS p0 eqs es NoEllipsis) rhs wh ca -> do-              case hasEllipsis' p0 of-                ManyHoles -> throwError $ MultipleEllipses p0-                OneHole cxt ~(EllipsisP r) -> do-                  -- Replace the ellipsis by @p@.-                  let p1 = cxt p-                  let ell = ExpandedEllipsis r (numberOfWithPatterns p)-                  let d' = FunClause (LHS p1 eqs es ell) 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-                ZeroHoles _ -> do-                  -- We can have ellipses after a fun clause without.-                  -- They refer to the last clause that introduced new with-expressions.-                  -- Same here: If we have new with-expressions, the next ellipses will-                  -- refer to us.-                  -- Andreas, Jesper, 2017-05-13, issue #2578-                  -- 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__--    -- Turn function clauses into nice function clauses.-    mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]-    mkClauses _ [] _ = return []-    mkClauses x (Pragma (CatchallPragma r) : cs) True  = do-      niceWarning $ InvalidCatchallPragma r-      mkClauses x cs True-    mkClauses x (Pragma (CatchallPragma r) : cs) False = do-      when (null cs) $ niceWarning $ InvalidCatchallPragma r-      mkClauses x cs True--    mkClauses x (FunClause lhs rhs wh ca : cs) catchall-      | null (lhsWithExpr lhs) || hasEllipsis lhs  =-      (Clause x (ca || catchall) lhs rhs wh [] :) <$> mkClauses x cs False   -- Will result in an error later.--    mkClauses x (FunClause lhs rhs wh ca : cs) catchall = do-      when (null withClauses) $ throwError $ MissingWithClauses x lhs-      wcs <- mkClauses x withClauses False-      (Clause x (ca || catchall) lhs rhs wh wcs :) <$> mkClauses x cs' False-      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--        subClauses :: [Declaration] -> ([Declaration],[Declaration])-        subClauses (c@(FunClause (LHS p0 _ _ _) _ _ _) : cs)-         | isEllipsis p0 ||-           numberOfWithPatterns p0 >= numWith = mapFst (c:) (subClauses cs)-         | otherwise                           = ([], c:cs)-        subClauses (c@(Pragma (CatchallPragma r)) : cs) = case subClauses cs of-          ([], cs') -> ([], c:cs')-          (cs, cs') -> (c:cs, cs')-        subClauses [] = ([],[])-        subClauses _  = __IMPOSSIBLE__-    mkClauses _ _ _ = __IMPOSSIBLE__--    -- 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 _ _ _) _ _ _) = hasEllipsis p ||-      let-      pns        = patternNames p-      xStrings   = nameStringParts x-      patStrings = concatMap nameStringParts pns-      in---          trace ("x = " ++ prettyShow x) $---          trace ("pns = " ++ show pns) $---          trace ("xStrings = " ++ show xStrings) $---          trace ("patStrings = " ++ show patStrings) $---          trace ("mFixity = " ++ show mFixity) $-      case (listToMaybe pns, mFixity) of-        -- first identifier in the patterns is the fun.symbol?-        (Just y, _) | x == y -> True -- trace ("couldBe since y = " ++ prettyShow y) $ True-        -- are the parts of x contained in p-        _ | xStrings `isSublistOf` patStrings -> True -- trace ("couldBe since isSublistOf") $ True-        -- looking for a mixfix fun.symb-        (_, Just fix) ->  -- also matches in case of a postfix-           let notStrings = stringParts (theNotation fix)-           in  -- trace ("notStrings = " ++ show notStrings) $-               -- trace ("patStrings = " ++ show patStrings) $-               (not $ null notStrings) && (notStrings `isSublistOf` patStrings)-        -- not a notation, not first id: give up-        _ -> False -- trace ("couldBe not (case default)") $ False-    couldBeFunClauseOf _ _ _ = False -- trace ("couldBe not (fun default)") $ False--    -- | Turn an old-style mutual block into a new style mutual block-    --   by pushing the definitions to the end.-    mkOldMutual-      :: Range                -- ^ Range of the whole @mutual@ block.-      -> [NiceDeclaration]    -- ^ Declarations inside the block.-      -> Nice NiceDeclaration -- ^ Returns a 'NiceMutual'.-    mkOldMutual r ds' = do-        -- Postulate the missing definitions-        let ps = loneSigsFromLoneNames loneNames-        checkLoneSigs ps-        let ds = replaceSigs ps ds'--        -- -- 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-        --   -- Andreas, 2013-11-23 allow postulates in mutual blocks-        --   Axiom{}          -> success-        --   -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature-        --   -- in ConcreteToAbstract rather than here.-        --   NiceFunClause{}  -> success-        --   -- Andreas, 2018-05-11, issue #3052, allow pat.syn.s in mutual blocks-        --   NicePatternSyn{} -> success-        --   -- Otherwise, only categorized signatures and definitions are allowed:-        --   -- Data, Record, Fun-        --   _ -> if (declKind d /= OtherDecl) then success-        --        else Nothing <$ niceWarning (NotAllowedInMutual (getRange d) $ declName d)-        -- Sort the declarations in the mutual block.-        -- Declarations of names go to the top.  (Includes module definitions.)-        -- 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-          let top       = return (In1 d)-              bottom    = return (In2 d)-              invalid s = In3 d <$ do niceWarning $ NotAllowedInMutual (getRange d) s-          case d of-            -- Andreas, 2013-11-23 allow postulates in mutual blocks-            Axiom{}             -> top-            NiceField{}         -> top-            PrimitiveFunction{} -> top-            -- Andreas, 2019-07-23 issue #3932:-            -- Nested mutual blocks are not supported.-            NiceMutual{}        -> invalid "mutual blocks"-            -- Andreas, 2018-10-29, issue #3246-            -- We could allow modules (top), but this is potentially confusing.-            NiceModule{}        -> invalid "Module definitions"-            NiceModuleMacro{}   -> top-            NiceOpen{}          -> top-            NiceImport{}        -> top-            NiceRecSig{}        -> top-            NiceDataSig{}       -> top-            -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature-            -- in ConcreteToAbstract rather than here.-            NiceFunClause{}     -> bottom-            FunSig{}            -> top-            FunDef{}            -> bottom-            NiceDataDef{}       -> bottom-            NiceRecDef{}        -> 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-            -- just above them.-            NicePatternSyn{}    -> bottom-            NiceGeneralize{}    -> top-            NiceUnquoteDecl{}   -> top-            NiceUnquoteDef{}    -> bottom-            NicePragma r pragma -> case pragma of--              OptionsPragma{}           -> top     -- error thrown in the type checker--              -- Some builtins require a definition, and they affect type checking-              -- Thus, we do not handle BUILTINs in mutual blocks (at least for now).-              BuiltinPragma{}           -> invalid "BUILTIN pragmas"--              -- The REWRITE pragma behaves differently before or after the def.-              -- and affects type checking.  Thus, we refuse it here.-              RewritePragma{}           -> invalid "REWRITE pragmas"--              -- Compiler pragmas are not needed for type checking, thus,-              -- can go to the bottom.-              ForeignPragma{}           -> bottom-              CompilePragma{}           -> bottom--              StaticPragma{}            -> bottom-              InlinePragma{}            -> bottom--              ImpossiblePragma{}        -> top     -- error thrown in scope checker-              EtaPragma{}               -> bottom  -- needs record definition-              WarningOnUsage{}          -> top-              WarningOnImport{}         -> top-              InjectivePragma{}         -> top     -- only needs name, not definition-              DisplayPragma{}           -> top     -- only for printing--              -- The attached pragmas have already been handled at this point.-              CatchallPragma{}          -> __IMPOSSIBLE__-              TerminationCheckPragma{}  -> __IMPOSSIBLE__-              NoPositivityCheckPragma{} -> __IMPOSSIBLE__-              PolarityPragma{}          -> __IMPOSSIBLE__-              NoUniverseCheckPragma{}   -> __IMPOSSIBLE__-              NoCoverageCheckPragma{}   -> __IMPOSSIBLE__--        -- -- Pull type signatures to the top-        -- let (sigs, other) = List.partition isTypeSig ds--        -- -- Push definitions to the bottom-        -- let (other, defs) = flip List.partition ds $ \case-        --       FunDef{}         -> False-        --       NiceDataDef{}    -> False-        --       NiceRecDef{}         -> False-        --       NiceFunClause{}  -> False-        --       NicePatternSyn{} -> False-        --       NiceUnquoteDef{} -> False-        --       _ -> True--        -- Compute termination checking flag for mutual block-        tc0 <- use terminationCheckPragma-        let tcs = map termCheck ds-        tc <- combineTerminationChecks r (tc0:tcs)--        -- Compute coverage checking flag for mutual block-        cc0 <- use coverageCheckPragma-        let ccs = map covCheck ds-        let cc = combineCoverageChecks (cc0:ccs)--        -- Compute positivity checking flag for mutual block-        pc0 <- use positivityCheckPragma-        let pcs = map positivityCheckOldMutual ds-        let pc = combinePositivityChecks (pc0:pcs)--        return $ NiceMutual r tc cc pc $ top ++ bottom-        -- return $ NiceMutual r tc pc $ other ++ defs-        -- return $ NiceMutual r tc pc $ sigs ++ other-      where--        -- isTypeSig Axiom{}                     = True-        -- isTypeSig d | LoneSig{} <- declKind d = True-        -- isTypeSig _                           = False--        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 ]--        termCheck :: NiceDeclaration -> TerminationCheck-        -- Andreas, 2013-02-28 (issue 804):-        -- do not termination check a mutual block if any of its-        -- inner declarations comes with a {-# NO_TERMINATION_CHECK #-}-        termCheck (FunSig _ _ _ _ _ _ tc _ _ _)      = tc-        termCheck (FunDef _ _ _ _ tc _ _ _)          = tc-        -- ASR (28 December 2015): Is this equation necessary?-        termCheck (NiceMutual _ tc _ _ _)            = tc-        termCheck (NiceUnquoteDecl _ _ _ _ tc _ _ _) = tc-        termCheck (NiceUnquoteDef _ _ _ tc _ _ _)    = tc-        termCheck Axiom{}             = TerminationCheck-        termCheck NiceField{}         = TerminationCheck-        termCheck PrimitiveFunction{} = TerminationCheck-        termCheck NiceModule{}        = TerminationCheck-        termCheck NiceModuleMacro{}   = TerminationCheck-        termCheck NiceOpen{}          = TerminationCheck-        termCheck NiceImport{}        = TerminationCheck-        termCheck NicePragma{}        = TerminationCheck-        termCheck NiceRecSig{}        = TerminationCheck-        termCheck NiceDataSig{}       = TerminationCheck-        termCheck NiceFunClause{}     = TerminationCheck-        termCheck NiceDataDef{}       = TerminationCheck-        termCheck NiceRecDef{}        = TerminationCheck-        termCheck NicePatternSyn{}    = TerminationCheck-        termCheck NiceGeneralize{}    = TerminationCheck--        covCheck :: NiceDeclaration -> CoverageCheck-        covCheck (FunSig _ _ _ _ _ _ _ cc _ _)      = cc-        covCheck (FunDef _ _ _ _ _ cc _ _)          = cc-        -- ASR (28 December 2015): Is this equation necessary?-        covCheck (NiceMutual _ _ cc _ _)            = cc-        covCheck (NiceUnquoteDecl _ _ _ _ _ cc _ _) = cc-        covCheck (NiceUnquoteDef _ _ _ _ cc _ _)    = cc-        covCheck Axiom{}             = YesCoverageCheck-        covCheck NiceField{}         = YesCoverageCheck-        covCheck PrimitiveFunction{} = YesCoverageCheck-        covCheck NiceModule{}        = YesCoverageCheck-        covCheck NiceModuleMacro{}   = YesCoverageCheck-        covCheck NiceOpen{}          = YesCoverageCheck-        covCheck NiceImport{}        = YesCoverageCheck-        covCheck NicePragma{}        = YesCoverageCheck-        covCheck NiceRecSig{}        = YesCoverageCheck-        covCheck NiceDataSig{}       = YesCoverageCheck-        covCheck NiceFunClause{}     = YesCoverageCheck-        covCheck NiceDataDef{}       = YesCoverageCheck-        covCheck NiceRecDef{}        = YesCoverageCheck-        covCheck NicePatternSyn{}    = YesCoverageCheck-        covCheck NiceGeneralize{}    = YesCoverageCheck----        -- ASR (26 December 2015): Do not positivity check a mutual-        -- block if any of its inner declarations comes with a-        -- NO_POSITIVITY_CHECK pragma. See Issue 1614.-        positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck-        positivityCheckOldMutual (NiceDataDef _ _ _ pc _ _ _ _) = pc-        positivityCheckOldMutual (NiceDataSig _ _ _ pc _ _ _ _) = pc-        positivityCheckOldMutual (NiceMutual _ _ _ pc _)        = pc-        positivityCheckOldMutual (NiceRecSig _ _ _ pc _ _ _ _)  = pc-        positivityCheckOldMutual (NiceRecDef _ _ _ pc _ _ _ _ _ _ _) = pc-        positivityCheckOldMutual _                              = YesPositivityCheck--        -- A mutual block cannot have a measure,-        -- but it can skip termination check.--    abstractBlock _ [] = return []-    abstractBlock r ds = do-      (ds', anyChange) <- runChangeT $ mkAbstract ds-      let inherited = r == noRange-      if anyChange then return ds' else do-        -- hack to avoid failing on inherited abstract blocks in where clauses-        unless inherited $ niceWarning $ UselessAbstract r-        return ds -- no change!--    privateBlock _ _ [] = return []-    privateBlock r o ds = do-      (ds', anyChange) <- runChangeT $ mkPrivate o ds-      if anyChange then return ds' else do-        when (o == UserWritten) $ niceWarning $ UselessPrivate r-        return ds -- no change!--    instanceBlock-      :: Range  -- ^ Range of @instance@ keyword.-      -> [NiceDeclaration]-      -> Nice [NiceDeclaration]-    instanceBlock _ [] = return []-    instanceBlock r ds = do-      let (ds', anyChange) = runChange $ mapM (mkInstance r) ds-      if anyChange then return ds' else do-        niceWarning $ UselessInstance r-        return ds -- no change!--    -- Make a declaration eligible for instance search.-    mkInstance-      :: Range  -- ^ 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-        NiceMutual r tc cc pc ds        -> NiceMutual r tc cc pc <$> mapM (mkInstance r0) ds-        d@NiceFunClause{}              -> return d-        FunDef r ds a i tc cc x cs     -> (\ i -> FunDef r ds a i tc cc x cs) <$> setInstance r0 i-        d@NiceField{}                  -> return d  -- Field instance are handled by the parser-        d@PrimitiveFunction{}          -> return d-        d@NiceUnquoteDef{}             -> return d-        d@NiceRecSig{}                 -> return d-        d@NiceDataSig{}                -> return d-        d@NiceModuleMacro{}            -> return d-        d@NiceModule{}                 -> return d-        d@NicePragma{}                 -> return d-        d@NiceOpen{}                   -> return d-        d@NiceImport{}                 -> return d-        d@NiceDataDef{}                -> return d-        d@NiceRecDef{}                 -> return d-        d@NicePatternSyn{}             -> return d-        d@NiceGeneralize{}             -> return d--    setInstance-      :: Range  -- ^ Range of @instance@ keyword.-      -> Updater IsInstance-    setInstance r0 = \case-      i@InstanceDef{} -> return i-      _               -> dirty $ InstanceDef r0--    macroBlock r ds = mapM mkMacro ds--    mkMacro :: NiceDeclaration -> Nice NiceDeclaration-    mkMacro = \case-        FunSig r p a i _ rel tc cc x e -> return $ FunSig r p a i MacroDef rel tc cc x e-        d@FunDef{}                     -> return d-        d                              -> throwError (BadMacroDef d)---- | Make a declaration abstract.------ Mark computation as 'dirty' if there was a declaration that could be made abstract.--- If no abstraction is taking place, we want to complain about 'UselessAbstract'.------ Alternatively, we could only flag 'dirty' if a non-abstract thing was abstracted.--- Then, nested @abstract@s would sometimes also be complained about.--class MakeAbstract a where-  mkAbstract :: UpdaterT Nice a-  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => UpdaterT Nice a-  mkAbstract = traverse mkAbstract--instance MakeAbstract a => MakeAbstract [a] where-  -- Default definition kicks in here!-  -- But note that we still have to declare the instance!---- Leads to overlap with 'WhereClause':--- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where---   mkAbstract = traverse mkAbstract--instance MakeAbstract IsAbstract where-  mkAbstract = \case-    a@AbstractDef -> return a-    ConcreteDef -> dirty $ AbstractDef--instance MakeAbstract NiceDeclaration where-  mkAbstract = \case-      NiceMutual r termCheck cc pc ds  -> NiceMutual r termCheck cc pc <$> mkAbstract ds-      FunDef r ds a i tc cc x cs       -> (\ a -> FunDef r ds a i tc cc x) <$> mkAbstract a <*> mkAbstract cs-      NiceDataDef r o a pc uc x ps cs  -> (\ a -> NiceDataDef r o a pc uc x ps) <$> mkAbstract a <*> mkAbstract cs-      NiceRecDef r o a pc uc x i e c ps cs -> (\ a -> NiceRecDef r o a pc uc x i e c ps) <$> mkAbstract a <*> return cs-      NiceFunClause r p a tc cc catchall d  -> (\ a -> NiceFunClause r p a tc cc catchall d) <$> mkAbstract a-      -- The following declarations have an @InAbstract@ field-      -- but are not really definitions, so we do count them into-      -- the declarations which can be made abstract-      -- (thus, do not notify progress with @dirty@).-      Axiom r 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 p a pc uc x ls t  -> return $ NiceRecSig        r p AbstractDef pc uc x ls t-      NiceDataSig r p a pc uc x ls t -> return $ NiceDataSig       r 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.-      -- Need to set updater state to dirty!-      NiceUnquoteDecl r p _ i tc cc x e -> tellDirty $> NiceUnquoteDecl r p AbstractDef i tc cc x e-      NiceUnquoteDef r p _ tc cc x e    -> tellDirty $> NiceUnquoteDef r p AbstractDef tc cc x e-      d@NiceModule{}                 -> return d-      d@NiceModuleMacro{}            -> return d-      d@NicePragma{}                 -> return d-      d@(NiceOpen _ _ directives)              -> do-        whenJust (publicOpen directives) $ lift . niceWarning . OpenPublicAbstract-        return d-      d@NiceImport{}                 -> return d-      d@NicePatternSyn{}             -> return d-      d@NiceGeneralize{}             -> return d--instance MakeAbstract Clause where-  mkAbstract (Clause x catchall lhs rhs wh with) = do-    Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with---- | Contents of a @where@ clause are abstract if the parent is.-instance MakeAbstract WhereClause where-  mkAbstract  NoWhere           = return $ NoWhere-  mkAbstract (AnyWhere ds)      = dirty $ AnyWhere [Abstract noRange ds]-  mkAbstract (SomeWhere m a ds) = dirty $ SomeWhere m a [Abstract noRange ds]---- | Make a declaration private.------ Andreas, 2012-11-17:--- Mark computation as 'dirty' if there was a declaration that could be privatized.--- If no privatization is taking place, we want to complain about 'UselessPrivate'.------ Alternatively, we could only flag 'dirty' if a non-private thing was privatized.--- Then, nested @private@s would sometimes also be complained about.--class MakePrivate a where-  mkPrivate :: Origin -> UpdaterT Nice a-  default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> UpdaterT Nice a-  mkPrivate o = traverse $ mkPrivate o--instance MakePrivate a => MakePrivate [a] where-  -- Default definition kicks in here!-  -- But note that we still have to declare the instance!---- Leads to overlap with 'WhereClause':--- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where---   mkPrivate = traverse mkPrivate--instance MakePrivate Access where-  mkPrivate o = \case-    p@PrivateAccess{} -> return p  -- OR? return $ PrivateAccess o-    _                 -> dirty $ PrivateAccess o--instance MakePrivate NiceDeclaration where-  mkPrivate o = \case-      Axiom r p a i rel x e                    -> (\ p -> Axiom r p a i rel x e)                <$> mkPrivate o p-      NiceField r p a i tac x e                -> (\ p -> NiceField r p a i tac x e)            <$> mkPrivate o p-      PrimitiveFunction r p a x e              -> (\ p -> PrimitiveFunction r p a x e)          <$> mkPrivate o p-      NiceMutual r tc cc pc ds                 -> (\ ds-> NiceMutual r tc cc pc ds)             <$> mkPrivate o ds-      NiceModule r p a x tel ds                -> (\ p -> NiceModule r p a x tel ds)            <$> mkPrivate o p-      NiceModuleMacro r p x ma op is           -> (\ p -> NiceModuleMacro r p x ma op is)       <$> mkPrivate o p-      FunSig r p a i m rel tc cc x e           -> (\ p -> FunSig r p a i m rel tc cc x e)       <$> mkPrivate o p-      NiceRecSig r p a pc uc x ls t            -> (\ p -> NiceRecSig r p a pc uc x ls t)        <$> mkPrivate o p-      NiceDataSig r p a pc uc x ls t           -> (\ p -> NiceDataSig r p a pc uc x ls t)       <$> mkPrivate o p-      NiceFunClause r p a tc cc catchall d     -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate o p-      NiceUnquoteDecl r p a i tc cc x e        -> (\ p -> NiceUnquoteDecl r p a i tc cc x e)    <$> mkPrivate o p-      NiceUnquoteDef r p a tc cc x e           -> (\ p -> NiceUnquoteDef r p a tc cc x e)       <$> mkPrivate o p-      NicePatternSyn r p x xs p'               -> (\ p -> NicePatternSyn r p x xs p')           <$> mkPrivate o p-      NiceGeneralize r p i tac x t             -> (\ p -> NiceGeneralize r p i tac x t)         <$> mkPrivate o p-      d@NicePragma{}                           -> return d-      d@(NiceOpen _ _ directives)              -> do-        whenJust (publicOpen directives) $ lift . niceWarning . OpenPublicPrivate-        return d-      d@NiceImport{}                           -> return d-      -- 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 o cls-      d@NiceDataDef{}                          -> return d-      d@NiceRecDef{}                           -> return d--instance MakePrivate Clause where-  mkPrivate o (Clause x catchall lhs rhs wh with) = do-    Clause x catchall lhs rhs <$> mkPrivate o wh <*> mkPrivate o with--instance MakePrivate WhereClause where-  mkPrivate o  NoWhere         = return $ NoWhere-  -- @where@-declarations are protected behind an anonymous module,-  -- thus, they are effectively private by default.-  mkPrivate o (AnyWhere ds)    = return $ AnyWhere ds-  -- Andreas, 2016-07-08-  -- A @where@-module is private if the parent function is private.-  -- The contents of this module are not private, unless declared so!-  -- Thus, we do not recurse into the @ds@ (could not anyway).-  mkPrivate o (SomeWhere m a ds) = mkPrivate o a <&> \ a' -> SomeWhere m a' ds---- The following function is (at the time of writing) only used three--- times: for building Lets, and for printing error messages.---- | (Approximately) convert a 'NiceDeclaration' back to a list of--- 'Declaration's.-notSoNiceDeclarations :: NiceDeclaration -> [Declaration]-notSoNiceDeclarations = \case-    Axiom _ _ _ i rel x e          -> inst i [TypeSig rel Nothing x e]-    NiceField _ _ _ i tac x argt   -> [FieldSig i tac x argt]-    PrimitiveFunction r _ _ x e    -> [Primitive r [TypeSig defaultArgInfo Nothing x e]]-    NiceMutual r _ _ _ ds          -> [Mutual r $ concatMap notSoNiceDeclarations ds]-    NiceModule r _ _ x tel ds      -> [Module r x tel ds]-    NiceModuleMacro r _ x ma o dir -> [ModuleMacro r x ma o dir]-    NiceOpen r x dir               -> [Open r x dir]-    NiceImport r x as o dir        -> [Import r x as o dir]-    NicePragma _ p                 -> [Pragma p]-    NiceRecSig r _ _ _ _ x bs e    -> [RecordSig r x bs e]-    NiceDataSig r _ _ _ _ x bs e   -> [DataSig r x bs e]-    NiceFunClause _ _ _ _ _ _ d    -> [d]-    FunSig _ _ _ i _ rel _ _ x e   -> inst i [TypeSig rel Nothing x e]-    FunDef _ ds _ _ _ _ _ _        -> ds-    NiceDataDef r _ _ _ _ x bs cs  -> [DataDef r x bs $ concatMap notSoNiceDeclarations cs]-    NiceRecDef r _ _ _ _ x i e c bs ds -> [RecordDef r x i e c bs ds]-    NicePatternSyn r _ n as p      -> [PatternSyn r n as p]-    NiceGeneralize r _ i tac n e   -> [Generalize r [TypeSig i tac n e]]-    NiceUnquoteDecl r _ _ i _ _ x e -> inst i [UnquoteDecl r x e]-    NiceUnquoteDef r _ _ _ _ x e    -> [UnquoteDef r x e]-  where-    inst (InstanceDef r) ds = [InstanceB r ds]-    inst NotInstanceDef  ds = ds---- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?-niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract-niceHasAbstract = \case-    Axiom{}                       -> Nothing-    NiceField _ _ a _ _ _ _       -> Just a-    PrimitiveFunction _ _ a _ _   -> Just a-    NiceMutual{}                  -> Nothing-    NiceModule _ _ a _ _ _        -> Just a-    NiceModuleMacro{}             -> Nothing-    NiceOpen{}                    -> Nothing-    NiceImport{}                  -> Nothing-    NicePragma{}                  -> Nothing-    NiceRecSig{}                  -> Nothing-    NiceDataSig{}                 -> Nothing-    NiceFunClause _ _ a _ _ _ _   -> Just a-    FunSig{}                      -> Nothing-    FunDef _ _ a _ _ _ _ _        -> Just a-    NiceDataDef _ _ a _ _ _ _ _   -> Just a-    NiceRecDef _ _ a _ _ _ _ _ _ _ _ -> Just a+{-# LANGUAGE GADTs              #-}++-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.+--+--   * Attach fixity and syntax declarations to the definition they refer to.+--+--   * Distribute the following attributes to the individual definitions:+--       @abstract@,+--       @instance@,+--       @postulate@,+--       @primitive@,+--       @private@,+--       termination pragmas.+--+--   * Gather the function clauses belonging to one function definition.+--+--   * Expand ellipsis @...@ in function clauses following @with@.+--+--   * Infer mutual blocks.+--     A block starts when a lone signature is encountered, and ends when+--     all lone signatures have seen their definition.+--+--   * Handle interleaved mutual blocks.+--     In an `interleaved mutual' block we:+--     * leave the data and fun sigs in place+--     * classify signatures in `constructor' block based on their return type+--       and group them all as a data def at the position in the block where the+--       first constructor for the data sig in question occured+--     * classify fun clauses based on the declared function used and group them+--       all as a fundef at the position in the block where the first such fun+--       clause appeared+--+--   * Report basic well-formedness error,+--     when one of the above transformation fails.+--     When possible, errors should be deferred to the scope checking phase+--     (ConcreteToAbstract), where we are in the TCM and can produce more+--     informative error messages.+++module Agda.Syntax.Concrete.Definitions+    ( NiceDeclaration(..)+    , NiceConstructor, NiceTypeSignature+    , Clause(..)+    , DeclarationException(..)+    , DeclarationWarning(..), DeclarationWarning'(..), unsafeDeclarationWarning+    , Nice, runNice+    , niceDeclarations+    , notSoNiceDeclarations+    , niceHasAbstract+    , Measure+    , declarationWarningName+    ) where+++import Prelude hiding (null)++import Control.Monad.Except+import Control.Monad.State++import Data.Bifunctor+import Data.Data (Data)+import Data.Either (isLeft, isRight)+import Data.Function (on)+import qualified Data.Map as Map+import Data.Map (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 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.Concrete.Definitions.Errors+import Agda.Syntax.Concrete.Definitions.Monad+import Agda.Syntax.Concrete.Definitions.Types++import Agda.Interaction.Options.Warnings++import Agda.Utils.AffineHole+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List (isSublistOf, spanJust)+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Null+import Agda.Utils.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Three+import Agda.Utils.Tuple+import Agda.Utils.Update++import Agda.Utils.Impossible++{--------------------------------------------------------------------------+    The niceifier+ --------------------------------------------------------------------------}++-- | Check that declarations in a mutual block are consistently+--   equipped with MEASURE pragmas, or whether there is a+--   NO_TERMINATION_CHECK pragma.+combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck+combineTerminationChecks r tcs = loop tcs where+  loop :: [TerminationCheck] -> Nice TerminationCheck+  loop []         = return TerminationCheck+  loop (tc : tcs) = do+    let failure r = declarationException $ InvalidMeasureMutual r+    tc' <- loop tcs+    case (tc, tc') of+      (TerminationCheck      , tc'                   ) -> return tc'+      (tc                    , TerminationCheck      ) -> return tc+      (NonTerminating        , NonTerminating        ) -> return NonTerminating+      (NoTerminationCheck    , NoTerminationCheck    ) -> return NoTerminationCheck+      (NoTerminationCheck    , Terminating           ) -> return Terminating+      (Terminating           , NoTerminationCheck    ) -> return Terminating+      (Terminating           , Terminating           ) -> return Terminating+      (TerminationMeasure{}  , TerminationMeasure{}  ) -> return tc+      (TerminationMeasure r _, NoTerminationCheck    ) -> failure r+      (TerminationMeasure r _, Terminating           ) -> failure r+      (NoTerminationCheck    , TerminationMeasure r _) -> failure r+      (Terminating           , TerminationMeasure r _) -> failure r+      (TerminationMeasure r _, NonTerminating        ) -> failure r+      (NonTerminating        , TerminationMeasure r _) -> failure r+      (NoTerminationCheck    , NonTerminating        ) -> failure r+      (Terminating           , NonTerminating        ) -> failure r+      (NonTerminating        , NoTerminationCheck    ) -> failure r+      (NonTerminating        , Terminating           ) -> failure r++combineCoverageChecks :: [CoverageCheck] -> CoverageCheck+combineCoverageChecks = Fold.fold++combinePositivityChecks :: [PositivityCheck] -> PositivityCheck+combinePositivityChecks = Fold.fold++data DeclKind+    = LoneSigDecl Range DataRecOrFun Name+    | LoneDefs DataRecOrFun [Name]+    | OtherDecl+  deriving (Eq, Show)++declKind :: NiceDeclaration -> DeclKind+declKind (FunSig r _ _ _ _ _ tc cc x _)     = LoneSigDecl r (FunName tc cc) x+declKind (NiceRecSig r _ _ pc uc x pars _)  = LoneSigDecl r (RecName pc uc) x+declKind (NiceDataSig r _ _ pc uc x pars _) = LoneSigDecl r (DataName pc uc) x+declKind (FunDef r _ abs ins tc cc x _)     = LoneDefs (FunName tc cc) [x]+declKind (NiceDataDef _ _ _ pc uc x pars _) = LoneDefs (DataName pc uc) [x]+declKind (NiceRecDef _ _ _ pc uc x _ pars _) = LoneDefs (RecName pc uc) [x]+declKind (NiceUnquoteDef _ _ _ tc cc xs _)  = LoneDefs (FunName tc cc) xs+declKind Axiom{}                            = OtherDecl+declKind NiceField{}                        = OtherDecl+declKind PrimitiveFunction{}                = OtherDecl+declKind NiceMutual{}                       = OtherDecl+declKind NiceModule{}                       = OtherDecl+declKind NiceModuleMacro{}                  = OtherDecl+declKind NiceOpen{}                         = OtherDecl+declKind NiceImport{}                       = OtherDecl+declKind NicePragma{}                       = OtherDecl+declKind NiceFunClause{}                    = OtherDecl+declKind NicePatternSyn{}                   = OtherDecl+declKind NiceGeneralize{}                   = OtherDecl+declKind NiceUnquoteDecl{}                  = OtherDecl+declKind NiceLoneConstructor{}              = OtherDecl++-- | Replace (Data/Rec/Fun)Sigs with Axioms 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+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+      Just (x, axiom)+        | (Just (LoneSig _ x' _), ps') <- Map.updateLookupWithKey (\ _ _ -> Nothing) x ps+        , getRange x == getRange x'+            -- Use the range as UID to ensure we do not replace the wrong signature.+            -- This could happen if the user wrote a duplicate definition.+        -> axiom : replaceSigs ps' ds+      _ -> d     : replaceSigs ps  ds++  where++    -- A @replaceable@ declaration is a signature. It has a name and we can make an+    -- @Axiom@ out of it.+    replaceable :: NiceDeclaration -> Maybe (Name, NiceDeclaration)+    replaceable = \case+      FunSig r acc abst inst _ argi _ _ x' e ->+        -- #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 argi x' e)+      NiceRecSig r acc abst _ _ x pars t ->+        let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in+        Just (x, Axiom r acc abst NotInstanceDef defaultArgInfo x e)+      NiceDataSig r acc abst _ _ x pars t ->+        let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in+        Just (x, Axiom r acc abst NotInstanceDef defaultArgInfo x e)+      _ -> Nothing++-- | Main. Fixities (or more precisely syntax declarations) are needed when+--   grouping function clauses.+niceDeclarations :: Fixities -> [Declaration] -> Nice [NiceDeclaration]+niceDeclarations fixs ds = do++  -- Run the nicifier in an initial environment. But keep the warnings.+  st <- get+  put $ initNiceEnv { niceWarn = niceWarn st }+  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++  -- Note that loneSigs is ensured to be empty.+  -- (Important, since inferMutualBlocks also uses loneSigs state).+  res <- inferMutualBlocks ds++  -- Restore the old state, but keep the warnings.+  warns <- gets niceWarn+  put $ st { niceWarn = warns }+  return res++  where++    inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]+    inferMutualBlocks [] = return []+    inferMutualBlocks (d : ds) =+      case declKind d of+        OtherDecl    -> (d :) <$> inferMutualBlocks ds+        LoneDefs{}   -> (d :) <$> inferMutualBlocks ds  -- Andreas, 2017-10-09, issue #2576: report error in ConcreteToAbstract+        LoneSigDecl r k x  -> do+          _ <- 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 then keep processing the rest of the block+          tc <- combineTerminationChecks (getRange d) (mutualTermination checks)+          let cc = combineCoverageChecks              (mutualCoverage checks)+          let pc = combinePositivityChecks            (mutualPositivity checks)+          (NiceMutual (getRange ds0) tc cc pc ds0 :) <$> inferMutualBlocks ds1+      where+        untilAllDefined :: MutualChecks -> [NiceDeclaration] -> Nice InferredMutual+        untilAllDefined checks ds = do+          done <- noLoneSigs+          if done then return (InferredMutual checks [] ds) else+            case ds of+              []     -> return (InferredMutual checks [] ds)+              d : ds -> case declKind d of+                LoneSigDecl r k x -> do+                  void $ addLoneSig r x k+                  extendInferredBlock  d <$> untilAllDefined (mutualChecks k <> checks) ds+                LoneDefs k xs -> do+                  mapM_ removeLoneSig xs+                  extendInferredBlock  d <$> untilAllDefined (mutualChecks k <> checks) ds+                OtherDecl -> extendInferredBlock d <$> untilAllDefined checks ds++    nice :: [Declaration] -> Nice [NiceDeclaration]+    nice [] = return []+    nice ds = do+      (xs , ys) <- nice1 ds+      (xs ++) <$> nice ys++    nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])+    nice1 []     = return ([], []) -- Andreas, 2017-09-16, issue #2759: no longer __IMPOSSIBLE__+    nice1 (d:ds) = do+      let justWarning :: HasCallStack => DeclarationWarning' -> Nice ([NiceDeclaration], [Declaration])+          justWarning w = do+            -- NOTE: This is the location of the invoker of justWarning, not here.+            withCallerCallStack $ declarationWarning' w+            nice1 ds++      case d of++        TypeSig info _tac x t -> do+          termCheck <- use terminationCheckPragma+          covCheck  <- use coverageCheckPragma+          -- Andreas, 2020-09-28, issue #4950: take only range of identifier,+          -- since parser expands type signatures with several identifiers+          -- (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+          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+        FieldSig{} -> __IMPOSSIBLE__++        Generalize r [] -> justWarning $ EmptyGeneralize r+        Generalize r sigs -> do+          gs <- forM sigs $ \case+            sig@(TypeSig info tac x t) -> do+              return $ NiceGeneralize (getRange sig) PublicAccess info tac x t+            _ -> __IMPOSSIBLE__+          return (gs, ds)++        (FunClause lhs _ _ _)         -> do+          termCheck <- use terminationCheckPragma+          covCheck  <- use coverageCheckPragma+          catchall  <- popCatchallPragma+          xs <- loneFuns <$> use loneSigs+          -- for each type signature 'x' waiting for clauses, we try+          -- if we have some clauses for 'x'+          case [ (x, (x', fits, rest))+               | (x, x') <- xs+               , let (fits, rest) =+                      -- Anonymous declarations only have 1 clause each!+                      if isNoName x then ([d], ds)+                      else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)+               , not (null fits)+               ] of++            -- case: clauses match none of the sigs+            [] -> case lhs of+              -- Subcase: The lhs is single identifier (potentially anonymous).+              -- Treat it as a function clause without a type signature.+              LHS p [] [] | Just x <- isSingleIdentifierP p -> do+                d  <- mkFunDef (setOrigin Inserted defaultArgInfo) termCheck covCheck x Nothing [d] -- fun def without type signature is relevant+                return (d , ds)+              -- Subcase: The lhs is a proper pattern.+              -- This could be a let-pattern binding. Pass it on.+              -- A missing type signature error might be raise in ConcreteToAbstract+              _ -> do+                return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck covCheck catchall d] , ds)++            -- case: clauses match exactly one of the sigs+            [(x,(x',fits,rest))] -> do+               -- The x'@NoName{} is the unique version of x@NoName{}.+               removeLoneSig x+               ds  <- expandEllipsis fits+               cs  <- mkClauses x' ds False+               return ([FunDef (getRange fits) fits ConcreteDef NotInstanceDef termCheck covCheck x' cs] , rest)++            -- case: clauses match more than one sigs (ambiguity)+            xf:xfs -> declarationException $ AmbiguousFunClauses lhs $ List1.reverse $ fmap fst $ xf :| xfs+                 -- "ambiguous function clause; cannot assign it uniquely to one type signature"++        Field r [] -> justWarning $ EmptyField r+        Field _ fs -> (,ds) <$> niceAxioms FieldBlock fs++        DataSig r x tel t -> do+          pc <- use positivityCheckPragma+          uc <- use universeCheckPragma+          _ <- addLoneSig r x $ DataName pc uc+          (,ds) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x (Just (tel, t)) Nothing++        Data r 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 NiceDataSig (niceAxioms DataBlock) r x ((tel,) <$> mt) (Just (tel, cs))++        DataDef r x tel 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 Nothing+          (,ds) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x ((tel,) <$> mt) (Just (tel, cs))++        RecordSig r x tel t         -> do+          pc <- use positivityCheckPragma+          uc <- use universeCheckPragma+          _ <- addLoneSig r x $ RecName pc uc+          return ([NiceRecSig r PublicAccess ConcreteDef pc uc x tel t] , ds)++        Record r 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) NiceRecSig+                      return r x ((tel,) <$> mt) (Just (tel, cs))++        RecordDef r x dir tel 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 Nothing+          (,ds) <$> dataOrRec pc uc (\ r o a pc uc x tel cs -> NiceRecDef r o a pc uc x dir tel cs) NiceRecSig+                      return r x ((tel,) <$> mt) (Just (tel, cs))++        RecordDirective r -> justWarning $ InvalidRecordDirective (getRange r)++        Mutual r ds' -> do+          -- The lone signatures encountered so far are not in scope+          -- for the mutual definition+          forgetLoneSigs+          case ds' of+            [] -> justWarning $ EmptyMutual r+            _  -> (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))++        InterleavedMutual r ds' -> do+          -- The lone signatures encountered so far are not in scope+          -- for the mutual definition+          forgetLoneSigs+          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'+++        Abstract r []  -> justWarning $ EmptyAbstract r+        Abstract r ds' ->+          (,ds) <$> (abstractBlock r =<< nice ds')++        Private r UserWritten []  -> justWarning $ EmptyPrivate r+        Private r o ds' ->+          (,ds) <$> (privateBlock r o =<< nice ds')++        InstanceB r []  -> justWarning $ EmptyInstance r+        InstanceB r ds' ->+          (,ds) <$> (instanceBlock r =<< nice ds')++        Macro r []  -> justWarning $ EmptyMacro r+        Macro r ds' ->+          (,ds) <$> (macroBlock r =<< nice ds')++        Postulate r []  -> justWarning $ EmptyPostulate r+        Postulate _ ds' ->+          (,ds) <$> niceAxioms PostulateBlock ds'++        Primitive r []  -> justWarning $ EmptyPrimitive r+        Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')++        Module r x tel ds' -> return $+          ([NiceModule r PublicAccess ConcreteDef x tel ds'] , ds)++        ModuleMacro r x modapp op is -> return $+          ([NiceModuleMacro r PublicAccess x modapp op is] , ds)++        -- Fixity and syntax declarations and polarity pragmas have+        -- already been processed.+        Infix _ _  -> return ([], ds)+        Syntax _ _ -> return ([], ds)++        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)++        UnquoteDecl r xs e -> do+          tc <- use terminationCheckPragma+          cc <- use coverageCheckPragma+          return ([NiceUnquoteDecl r PublicAccess ConcreteDef NotInstanceDef tc cc xs e] , ds)++        UnquoteDef r xs e -> do+          sigs <- map fst . loneFuns <$> use loneSigs+          List1.ifNotNull (filter (`notElem` sigs) xs)+            {-then-} (declarationException . UnquoteDefRequiresSignature)+            {-else-} $ do+              mapM_ removeLoneSig xs+              return ([NiceUnquoteDef r PublicAccess ConcreteDef TerminationCheck YesCoverageCheck xs e] , ds)++        Pragma p -> nicePragma p ds++    nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])++    nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =+      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 =+      if canHaveTerminationCheckPragma ds then+        withTerminationCheckPragma tc $ nice1 ds+      else do+        declarationWarning $ InvalidTerminationCheckPragma r+        nice1 ds++    nicePragma (NoCoverageCheckPragma r) ds =+      if canHaveCoverageCheckPragma ds then+        withCoverageCheckPragma NoCoverageCheck $ nice1 ds+      else do+        declarationWarning $ InvalidCoverageCheckPragma r+        nice1 ds++    nicePragma (CatchallPragma r) ds =+      if canHaveCatchallPragma ds then+        withCatchallPragma True $ nice1 ds+      else do+        declarationWarning $ InvalidCatchallPragma r+        nice1 ds++    nicePragma (NoPositivityCheckPragma r) ds =+      if canHaveNoPositivityCheckPragma ds then+        withPositivityCheckPragma NoPositivityCheck $ nice1 ds+      else do+        declarationWarning $ InvalidNoPositivityCheckPragma r+        nice1 ds++    nicePragma (NoUniverseCheckPragma r) ds =+      if canHaveNoUniverseCheckPragma ds then+        withUniverseCheckPragma NoUniverseCheck $ nice1 ds+      else do+        declarationWarning $ InvalidNoUniverseCheckPragma r+        nice1 ds++    nicePragma p@CompilePragma{} ds = do+      declarationWarning $ PragmaCompiled (getRange p)+      return ([NicePragma (getRange p) p], ds)++    nicePragma (PolarityPragma{}) ds = return ([], ds)++    nicePragma (BuiltinPragma r str qn@(QName x)) ds = do+      return ([NicePragma r (BuiltinPragma r str qn)], ds)++    nicePragma p ds = return ([NicePragma (getRange p) p], ds)++    canHaveTerminationMeasure :: [Declaration] -> Bool+    canHaveTerminationMeasure [] = False+    canHaveTerminationMeasure (d:ds) = case d of+      TypeSig{} -> True+      (Pragma p) | isAttachedPragma p -> canHaveTerminationMeasure ds+      _         -> False++    canHaveTerminationCheckPragma :: [Declaration] -> Bool+    canHaveTerminationCheckPragma []     = False+    canHaveTerminationCheckPragma (d:ds) = case d of+      Mutual _ ds   -> any (canHaveTerminationCheckPragma . singleton) ds+      TypeSig{}     -> True+      FunClause{}   -> True+      UnquoteDecl{} -> True+      (Pragma p) | isAttachedPragma p -> canHaveTerminationCheckPragma ds+      _             -> False++    canHaveCoverageCheckPragma :: [Declaration] -> Bool+    canHaveCoverageCheckPragma = canHaveTerminationCheckPragma++    canHaveCatchallPragma :: [Declaration] -> Bool+    canHaveCatchallPragma []     = False+    canHaveCatchallPragma (d:ds) = case d of+      FunClause{} -> True+      (Pragma p) | isAttachedPragma p -> canHaveCatchallPragma ds+      _           -> False++    canHaveNoPositivityCheckPragma :: [Declaration] -> Bool+    canHaveNoPositivityCheckPragma []     = False+    canHaveNoPositivityCheckPragma (d:ds) = case d of+      Mutual _ ds                   -> any (canHaveNoPositivityCheckPragma . singleton) ds+      Data{}                        -> True+      DataSig{}                     -> True+      DataDef{}                     -> True+      Record{}                      -> True+      RecordSig{}                   -> True+      RecordDef{}                   -> True+      Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds+      _                             -> False++    canHaveNoUniverseCheckPragma :: [Declaration] -> Bool+    canHaveNoUniverseCheckPragma []     = False+    canHaveNoUniverseCheckPragma (d:ds) = case d of+      Data{}                        -> True+      DataSig{}                     -> True+      DataDef{}                     -> True+      Record{}                      -> True+      RecordSig{}                   -> True+      RecordDef{}                   -> True+      Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds+      _                             -> False++    -- Pragma that attaches to the following declaration.+    isAttachedPragma :: Pragma -> Bool+    isAttachedPragma = \case+      TerminationCheckPragma{}  -> True+      CatchallPragma{}          -> True+      NoPositivityCheckPragma{} -> True+      NoUniverseCheckPragma{}   -> 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++    dataOrRec+      :: forall a decl+      .  PositivityCheck+      -> UniverseCheck+      -> (Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [decl] -> NiceDeclaration)+         -- Construct definition.+      -> (Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> 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.+      -> Nice [NiceDeclaration]+    dataOrRec pc uc mkDef mkSig niceD r x mt mcs = do+      mds <- Trav.forM mcs $ \ (tel, cs) -> (tel,) <$> niceD cs+      -- 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+      -- generalizable variables differ in these cases.+      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+          -- 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++    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+      Pragma p@(RewritePragma r _ _) -> do+        return [ NicePragma r p ]+      d -> declarationException $ WrongContentBlock b $ getRange d++    toPrim :: NiceDeclaration -> NiceDeclaration+    toPrim (Axiom r p a i rel x t) = PrimitiveFunction r p a x (Arg rel t)+    toPrim _                       = __IMPOSSIBLE__++    -- Create a function definition.+    mkFunDef info termCheck covCheck x mt ds0 = do+      ds <- expandEllipsis ds0+      cs <- mkClauses x ds False+      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+          t = fromMaybe (underscore (getRange x)) mt++    underscore r = Underscore r Nothing+++    expandEllipsis :: [Declaration] -> Nice [Declaration]+    expandEllipsis [] = return []+    expandEllipsis (d@(FunClause lhs@(LHS p _ _) _ _ _) : ds)+      | hasEllipsis p = (d :) <$> expandEllipsis ds+      | otherwise     = (d :) <$> expand (killRange p) ds+      where+        expand :: Pattern -> [Declaration] -> Nice [Declaration]+        expand _ [] = return []+        expand p (d : ds) = do+          case d of+            Pragma (CatchallPragma _) -> do+                  (d :) <$> expand p ds+            FunClause (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+                  -- 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+                ZeroHoles _ -> do+                  -- We can have ellipses after a fun clause without.+                  -- They refer to the last clause that introduced new with-expressions.+                  -- Same here: If we have new with-expressions, the next ellipses will+                  -- refer to us.+                  -- Andreas, Jesper, 2017-05-13, issue #2578+                  -- 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__++    -- Turn function clauses into nice function clauses.+    mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]+    mkClauses _ [] _ = return []+    mkClauses x (Pragma (CatchallPragma r) : cs) True  = do+      declarationWarning $ InvalidCatchallPragma r+      mkClauses x cs True+    mkClauses x (Pragma (CatchallPragma r) : cs) False = do+      when (null cs) $ declarationWarning $ InvalidCatchallPragma r+      mkClauses x cs True++    mkClauses x (FunClause lhs rhs wh ca : cs) catchall+      | null (lhsWithExpr lhs) || hasEllipsis lhs  =+      (Clause x (ca || catchall) lhs rhs wh [] :) <$> mkClauses x cs False   -- Will result in an error later.++    mkClauses x (FunClause lhs rhs wh ca : cs) catchall = do+      when (null withClauses) $ declarationException $ MissingWithClauses x lhs+      wcs <- mkClauses x withClauses False+      (Clause x (ca || catchall) lhs rhs wh wcs :) <$> mkClauses x cs' False+      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++        subClauses :: [Declaration] -> ([Declaration],[Declaration])+        subClauses (c@(FunClause (LHS p0 _ _) _ _ _) : cs)+         | isEllipsis p0 ||+           numberOfWithPatterns p0 >= numWith = mapFst (c:) (subClauses cs)+         | otherwise                           = ([], c:cs)+        subClauses (c@(Pragma (CatchallPragma r)) : cs) = case subClauses cs of+          ([], cs') -> ([], c:cs')+          (cs, cs') -> (c:cs, cs')+        subClauses [] = ([],[])+        subClauses _  = __IMPOSSIBLE__+    mkClauses _ _ _ = __IMPOSSIBLE__++    couldBeCallOf :: Maybe Fixity' -> Name -> Pattern -> Bool+    couldBeCallOf mFixity x p =+      let+      pns        = patternNames p+      xStrings   = nameStringParts x+      patStrings = concatMap nameStringParts pns+      in+--          trace ("x = " ++ prettyShow x) $+--          trace ("pns = " ++ show pns) $+--          trace ("xStrings = " ++ show xStrings) $+--          trace ("patStrings = " ++ show patStrings) $+--          trace ("mFixity = " ++ show mFixity) $+      case (listToMaybe pns, mFixity) of+        -- first identifier in the patterns is the fun.symbol?+        (Just y, _) | x == y -> True -- trace ("couldBe since y = " ++ prettyShow y) $ True+        -- are the parts of x contained in p+        _ | xStrings `isSublistOf` patStrings -> True -- trace ("couldBe since isSublistOf") $ True+        -- looking for a mixfix fun.symb+        (_, Just fix) ->  -- also matches in case of a postfix+           let notStrings = stringParts (theNotation fix)+           in  -- trace ("notStrings = " ++ show notStrings) $+               -- trace ("patStrings = " ++ show patStrings) $+               not (null notStrings) && (notStrings `isSublistOf` patStrings)+        -- not a notation, not first id: give up+        _ -> False -- trace ("couldBe not (case default)") $ False+++    -- for finding nice clauses for a type sig in mutual blocks+    couldBeNiceFunClauseOf :: Maybe Fixity' -> Name -> NiceDeclaration+                           -> Maybe (MutualChecks, Declaration)+    couldBeNiceFunClauseOf mf n (NiceFunClause _ _ _ tc cc _ d)+      = (MutualChecks [tc] [cc] [], d) <$ guard (couldBeFunClauseOf mf n d)+    couldBeNiceFunClauseOf _ _ _ = Nothing++    -- 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 _ _) _ _ _) =+       hasEllipsis p || couldBeCallOf mFixity x p+    couldBeFunClauseOf _ _ _ = False -- trace ("couldBe not (fun default)") $ False++    -- Turn a new style `interleaved mutual' block into a new style mutual block+    -- by grouping the declarations in blocks.+    mkInterleavedMutual+      :: Range                 -- Range of the whole @mutual@ block.+      -> [NiceDeclaration]     -- Declarations inside the block.+      -> Nice NiceDeclaration  -- Returns a 'NiceMutual'.+    mkInterleavedMutual r ds' = do+      (other, (m, checks, _)) <- runStateT (groupByBlocks r ds') (empty, mempty, 0)+      let idecls = other ++ concatMap (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+      -- process the checks+      tc <- combineTerminationChecks r (mutualTermination checks)+      let cc = combineCoverageChecks   (mutualCoverage checks)+      let pc = combinePositivityChecks (mutualPositivity checks)+      pure $ NiceMutual r tc cc pc decls++      where++        ------------------------------------------------------------------------------+        -- Adding Signatures+        addType :: Name -> (Int -> a) -> MutualChecks+                -> StateT (Map Name a, MutualChecks, Int) Nice ()+        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)++        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+          let checks = MutualChecks [] [] [pc]+          addType n (\ i -> InterleavedData (i, d) Nothing) checks+        addDataType _ = __IMPOSSIBLE__++        ------------------------------------------------------------------------------+        -- Adding constructors & clauses++        addDataConstructors :: Maybe Name         -- Data type the constructors belong to+                            -> [NiceConstructor]  -- Constructors to add+                            -> StateT (InterleavedMutual, MutualChecks, Int) Nice ()+        -- if we know the type's name, we can go ahead+        addDataConstructors (Just n) ds = do+          (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')+            _ -> __IMPOSSIBLE__ -- we have resolved the name `n` already and it comes from a DataSig!++        addDataConstructors Nothing [] = pure ()++        -- Otherwise we try to guess which datasig the constructor is referring to+        addDataConstructors Nothing (d : ds) = do+          -- get the candidate data types that are in this interleaved mutual block+          (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 (Just n) (d : ds0)+              -- and then repeat the process for the rest of the block+              addDataConstructors Nothing ds1+            Left (n, ns) -> lift $ declarationException $ AmbiguousConstructor (getRange d) n ns++        addFunDef :: NiceDeclaration -> StateT (InterleavedMutual, MutualChecks, Int) Nice ()+        addFunDef (FunDef _ ds _ _ tc cc n cs) = do+          let check = MutualChecks [tc] [cc] []+          (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')+            _ -> __IMPOSSIBLE__ -- A FunDef always come after an existing FunSig!+        addFunDef _ = __IMPOSSIBLE__++        addFunClauses :: Range -> [NiceDeclaration]+                      -> StateT (InterleavedMutual, MutualChecks, Int) Nice [(Int, NiceDeclaration)]+        addFunClauses r (nd@(NiceFunClause _ _ _ tc cc _ d@(FunClause lhs _ _ _)) : ds) = do+          -- get the candidate functions that are in this interleaved mutual block+          (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)+               ] 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)+              ((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 False+              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__+              groupByBlocks r rest+            -- more than one candidate: fail, complaining about the ambiguity!+            xf:xfs -> lift $ declarationException+                           $ AmbiguousFunClauses lhs+                           $ List1.reverse $ fmap (\ (a,_,_) -> a) $ xf :| xfs+        addFunClauses _ _ = __IMPOSSIBLE__++        groupByBlocks :: Range -> [NiceDeclaration]+                      -> StateT (InterleavedMutual, MutualChecks, Int) Nice [(Int, NiceDeclaration)]+        groupByBlocks r []       = pure []+        groupByBlocks r (d : ds) = do+          -- for most branches we deal with the one declaration and move on+          let oneOff act = act >>= \ ns -> (ns ++) <$> groupByBlocks r ds+          case d of+            NiceDataSig{}                -> oneOff $ [] <$ addDataType d+            NiceDataDef _ _ _ _ _ n _ ds -> oneOff $ [] <$ addDataConstructors (Just n) ds+            NiceLoneConstructor r ds     -> oneOff $ [] <$ addDataConstructors Nothing ds+            FunSig{}                     -> oneOff $ [] <$ addFunType d+            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.+            NiceFunClause{}              -> addFunClauses r (d:ds)+            -- 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)+              pure [(i,d)]++    -- Extract the name of the return type (if any) of a potential constructor.+    -- In case of failure return the name of the constructor and the list of candidates+    -- for the return type.+    -- A `constructor' block should only contain NiceConstructors so we crash with+    -- an IMPOSSIBLE otherwise+    isConstructor :: [Name] -> NiceDeclaration -> Either (Name, [Name]) Name+    isConstructor ns (Axiom _ _ _ _ _ n e)+       -- extract the return type & see it as an LHS-style pattern+       | Just p <- exprToPatternWithHoles <$> returnExpr e =+         case [ x | x <- ns+                  , couldBeCallOf (Map.lookup x fixs) x p+                  ] of+           [x] -> Right x+           xs  -> Left (n, xs)+       -- which may fail (e.g. if the "return type" is a hole+       | otherwise = Left (n, [])+    isConstructor _ _ = __IMPOSSIBLE__++    -- Turn an old-style mutual block into a new style mutual block+    -- by pushing the definitions to the end.+    mkOldMutual+      :: Range                 -- Range of the whole @mutual@ block.+      -> [NiceDeclaration]     -- Declarations inside the block.+      -> Nice NiceDeclaration  -- Returns a 'NiceMutual'.+    mkOldMutual r ds' = do+        -- Postulate the missing definitions+        let ps = loneSigsFromLoneNames loneNames+        checkLoneSigs ps+        let ds = replaceSigs ps ds'++        -- -- 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+        --   -- Andreas, 2013-11-23 allow postulates in mutual blocks+        --   Axiom{}          -> success+        --   -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature+        --   -- in ConcreteToAbstract rather than here.+        --   NiceFunClause{}  -> success+        --   -- Andreas, 2018-05-11, issue #3052, allow pat.syn.s in mutual blocks+        --   NicePatternSyn{} -> success+        --   -- Otherwise, only categorized signatures and definitions are allowed:+        --   -- Data, Record, Fun+        --   _ -> if (declKind d /= OtherDecl) then success+        --        else Nothing <$ declarationWarning (NotAllowedInMutual (getRange d) $ declName d)+        -- Sort the declarations in the mutual block.+        -- Declarations of names go to the top.  (Includes module definitions.)+        -- 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+          let top       = return (In1 d)+              bottom    = return (In2 d)+              invalid s = In3 d <$ do declarationWarning $ NotAllowedInMutual (getRange d) s+          case d of+            -- Andreas, 2013-11-23 allow postulates in mutual blocks+            Axiom{}             -> top+            NiceField{}         -> top+            PrimitiveFunction{} -> top+            -- Andreas, 2019-07-23 issue #3932:+            -- Nested mutual blocks are not supported.+            NiceMutual{}        -> invalid "mutual blocks"+            -- Andreas, 2018-10-29, issue #3246+            -- We could allow modules (top), but this is potentially confusing.+            NiceModule{}        -> invalid "Module definitions"+            -- Lone constructors are only allowed in new-style mutual blocks+            NiceLoneConstructor{} -> invalid "Lone constructors"+            NiceModuleMacro{}   -> top+            NiceOpen{}          -> top+            NiceImport{}        -> top+            NiceRecSig{}        -> top+            NiceDataSig{}       -> top+            -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature+            -- in ConcreteToAbstract rather than here.+            NiceFunClause{}     -> bottom+            FunSig{}            -> top+            FunDef{}            -> bottom+            NiceDataDef{}       -> bottom+            NiceRecDef{}        -> 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+            -- just above them.+            NicePatternSyn{}    -> bottom+            NiceGeneralize{}    -> top+            NiceUnquoteDecl{}   -> top+            NiceUnquoteDef{}    -> bottom+            NicePragma r pragma -> case pragma of++              OptionsPragma{}           -> top     -- error thrown in the type checker++              -- Some builtins require a definition, and they affect type checking+              -- Thus, we do not handle BUILTINs in mutual blocks (at least for now).+              BuiltinPragma{}           -> invalid "BUILTIN pragmas"++              -- The REWRITE pragma behaves differently before or after the def.+              -- and affects type checking.  Thus, we refuse it here.+              RewritePragma{}           -> invalid "REWRITE pragmas"++              -- Compiler pragmas are not needed for type checking, thus,+              -- can go to the bottom.+              ForeignPragma{}           -> bottom+              CompilePragma{}           -> bottom++              StaticPragma{}            -> bottom+              InlinePragma{}            -> bottom++              ImpossiblePragma{}        -> top     -- error thrown in scope checker+              EtaPragma{}               -> bottom  -- needs record definition+              WarningOnUsage{}          -> top+              WarningOnImport{}         -> top+              InjectivePragma{}         -> top     -- only needs name, not definition+              DisplayPragma{}           -> top     -- only for printing++              -- The attached pragmas have already been handled at this point.+              CatchallPragma{}          -> __IMPOSSIBLE__+              TerminationCheckPragma{}  -> __IMPOSSIBLE__+              NoPositivityCheckPragma{} -> __IMPOSSIBLE__+              PolarityPragma{}          -> __IMPOSSIBLE__+              NoUniverseCheckPragma{}   -> __IMPOSSIBLE__+              NoCoverageCheckPragma{}   -> __IMPOSSIBLE__++        -- -- Pull type signatures to the top+        -- let (sigs, other) = List.partition isTypeSig ds++        -- -- Push definitions to the bottom+        -- let (other, defs) = flip List.partition ds $ \case+        --       FunDef{}         -> False+        --       NiceDataDef{}    -> False+        --       NiceRecDef{}         -> False+        --       NiceFunClause{}  -> False+        --       NicePatternSyn{} -> False+        --       NiceUnquoteDef{} -> False+        --       _ -> True++        -- Compute termination checking flag for mutual block+        tc0 <- use terminationCheckPragma+        let tcs = map termCheck ds+        tc <- combineTerminationChecks r (tc0:tcs)++        -- Compute coverage checking flag for mutual block+        cc0 <- use coverageCheckPragma+        let ccs = map covCheck ds+        let cc = combineCoverageChecks (cc0:ccs)++        -- Compute positivity checking flag for mutual block+        pc0 <- use positivityCheckPragma+        let pcs = map positivityCheckOldMutual ds+        let pc = combinePositivityChecks (pc0:pcs)++        return $ NiceMutual r tc cc pc $ top ++ bottom+        -- return $ NiceMutual r tc pc $ other ++ defs+        -- return $ NiceMutual r tc pc $ sigs ++ other+      where++        -- isTypeSig Axiom{}                     = True+        -- isTypeSig d | LoneSig{} <- declKind d = True+        -- isTypeSig _                           = False++        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 ]++        termCheck :: NiceDeclaration -> TerminationCheck+        -- Andreas, 2013-02-28 (issue 804):+        -- do not termination check a mutual block if any of its+        -- inner declarations comes with a {-# NO_TERMINATION_CHECK #-}+        termCheck (FunSig _ _ _ _ _ _ tc _ _ _)      = tc+        termCheck (FunDef _ _ _ _ tc _ _ _)          = tc+        -- ASR (28 December 2015): Is this equation necessary?+        termCheck (NiceMutual _ tc _ _ _)            = tc+        termCheck (NiceUnquoteDecl _ _ _ _ tc _ _ _) = tc+        termCheck (NiceUnquoteDef _ _ _ tc _ _ _)    = tc+        termCheck Axiom{}             = TerminationCheck+        termCheck NiceField{}         = TerminationCheck+        termCheck PrimitiveFunction{} = TerminationCheck+        termCheck NiceModule{}        = TerminationCheck+        termCheck NiceModuleMacro{}   = TerminationCheck+        termCheck NiceOpen{}          = TerminationCheck+        termCheck NiceImport{}        = TerminationCheck+        termCheck NicePragma{}        = TerminationCheck+        termCheck NiceRecSig{}        = TerminationCheck+        termCheck NiceDataSig{}       = TerminationCheck+        termCheck NiceFunClause{}     = TerminationCheck+        termCheck NiceDataDef{}       = TerminationCheck+        termCheck NiceRecDef{}        = TerminationCheck+        termCheck NicePatternSyn{}    = TerminationCheck+        termCheck NiceGeneralize{}    = TerminationCheck+        termCheck NiceLoneConstructor{} = TerminationCheck++        covCheck :: NiceDeclaration -> CoverageCheck+        covCheck (FunSig _ _ _ _ _ _ _ cc _ _)      = cc+        covCheck (FunDef _ _ _ _ _ cc _ _)          = cc+        -- ASR (28 December 2015): Is this equation necessary?+        covCheck (NiceMutual _ _ cc _ _)            = cc+        covCheck (NiceUnquoteDecl _ _ _ _ _ cc _ _) = cc+        covCheck (NiceUnquoteDef _ _ _ _ cc _ _)    = cc+        covCheck Axiom{}             = YesCoverageCheck+        covCheck NiceField{}         = YesCoverageCheck+        covCheck PrimitiveFunction{} = YesCoverageCheck+        covCheck NiceModule{}        = YesCoverageCheck+        covCheck NiceModuleMacro{}   = YesCoverageCheck+        covCheck NiceOpen{}          = YesCoverageCheck+        covCheck NiceImport{}        = YesCoverageCheck+        covCheck NicePragma{}        = YesCoverageCheck+        covCheck NiceRecSig{}        = YesCoverageCheck+        covCheck NiceDataSig{}       = YesCoverageCheck+        covCheck NiceFunClause{}     = YesCoverageCheck+        covCheck NiceDataDef{}       = YesCoverageCheck+        covCheck NiceRecDef{}        = YesCoverageCheck+        covCheck NicePatternSyn{}    = YesCoverageCheck+        covCheck NiceGeneralize{}    = YesCoverageCheck+        covCheck NiceLoneConstructor{} = YesCoverageCheck++        -- ASR (26 December 2015): Do not positivity check a mutual+        -- block if any of its inner declarations comes with a+        -- NO_POSITIVITY_CHECK pragma. See Issue 1614.+        positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck+        positivityCheckOldMutual (NiceDataDef _ _ _ pc _ _ _ _) = pc+        positivityCheckOldMutual (NiceDataSig _ _ _ pc _ _ _ _) = pc+        positivityCheckOldMutual (NiceMutual _ _ _ pc _)        = pc+        positivityCheckOldMutual (NiceRecSig _ _ _ pc _ _ _ _)  = pc+        positivityCheckOldMutual (NiceRecDef _ _ _ pc _ _ _ _ _) = pc+        positivityCheckOldMutual _                              = YesPositivityCheck++        -- A mutual block cannot have a measure,+        -- but it can skip termination check.++    abstractBlock _ [] = return []+    abstractBlock r ds = do+      (ds', anyChange) <- runChangeT $ mkAbstract ds+      let inherited = r == noRange+      if anyChange then return ds' else do+        -- hack to avoid failing on inherited abstract blocks in where clauses+        unless inherited $ declarationWarning $ UselessAbstract r+        return ds -- no change!++    privateBlock _ _ [] = return []+    privateBlock r o ds = do+      (ds', anyChange) <- runChangeT $ mkPrivate o ds+      if anyChange then return ds' else do+        when (o == UserWritten) $ declarationWarning $ UselessPrivate r+        return ds -- no change!++    instanceBlock+      :: Range  -- Range of @instance@ keyword.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]+    instanceBlock _ [] = return []+    instanceBlock r ds = do+      let (ds', anyChange) = runChange $ mapM (mkInstance r) ds+      if anyChange then return ds' else do+        declarationWarning $ UselessInstance r+        return ds -- no change!++    -- Make a declaration eligible for instance search.+    mkInstance+      :: Range  -- 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+        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+        FunDef r ds a i tc cc x cs     -> (\ i -> FunDef r ds a i tc cc x cs) <$> setInstance r0 i+        d@NiceField{}                  -> return d  -- Field instance are handled by the parser+        d@PrimitiveFunction{}          -> return d+        d@NiceUnquoteDef{}             -> return d+        d@NiceRecSig{}                 -> return d+        d@NiceDataSig{}                -> return d+        d@NiceModuleMacro{}            -> return d+        d@NiceModule{}                 -> return d+        d@NicePragma{}                 -> return d+        d@NiceOpen{}                   -> return d+        d@NiceImport{}                 -> return d+        d@NiceDataDef{}                -> return d+        d@NiceRecDef{}                 -> return d+        d@NicePatternSyn{}             -> return d+        d@NiceGeneralize{}             -> return d++    setInstance+      :: Range  -- Range of @instance@ keyword.+      -> Updater IsInstance+    setInstance r0 = \case+      i@InstanceDef{} -> return i+      _               -> dirty $ InstanceDef r0++    macroBlock r ds = mapM mkMacro ds++    mkMacro :: NiceDeclaration -> Nice NiceDeclaration+    mkMacro = \case+        FunSig r p a i _ rel tc cc x e -> return $ FunSig r p a i MacroDef rel tc cc x e+        d@FunDef{}                     -> return d+        d                              -> declarationException (BadMacroDef d)++-- | Make a declaration abstract.+--+-- Mark computation as 'dirty' if there was a declaration that could be made abstract.+-- If no abstraction is taking place, we want to complain about 'UselessAbstract'.+--+-- Alternatively, we could only flag 'dirty' if a non-abstract thing was abstracted.+-- Then, nested @abstract@s would sometimes also be complained about.++class MakeAbstract a where+  mkAbstract :: UpdaterT Nice a++  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => UpdaterT Nice a+  mkAbstract = traverse mkAbstract++instance MakeAbstract a => MakeAbstract [a]++-- Leads to overlap with 'WhereClause':+-- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where+--   mkAbstract = traverse mkAbstract++instance MakeAbstract IsAbstract where+  mkAbstract = \case+    a@AbstractDef -> return a+    ConcreteDef -> dirty $ AbstractDef++instance MakeAbstract NiceDeclaration where+  mkAbstract = \case+      NiceMutual r termCheck cc pc ds  -> NiceMutual r termCheck cc pc <$> mkAbstract ds+      NiceLoneConstructor r ds         -> NiceLoneConstructor r <$> mkAbstract ds+      FunDef r ds a i tc cc x cs       -> (\ a -> FunDef r ds a i tc cc x) <$> mkAbstract a <*> mkAbstract cs+      NiceDataDef r o a pc uc x ps cs  -> (\ a -> NiceDataDef r o a pc uc x ps) <$> mkAbstract a <*> mkAbstract cs+      NiceRecDef r o a pc uc x dir ps cs -> (\ a -> NiceRecDef r o a pc uc x dir ps cs) <$> mkAbstract a+      NiceFunClause r p a tc cc catchall d  -> (\ a -> NiceFunClause r p a tc cc catchall d) <$> mkAbstract a+      -- The following declarations have an @InAbstract@ field+      -- but are not really definitions, so we do count them into+      -- the declarations which can be made abstract+      -- (thus, do not notify progress with @dirty@).+      Axiom r 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 p a pc uc x ls t  -> return $ NiceRecSig        r p AbstractDef pc uc x ls t+      NiceDataSig r p a pc uc x ls t -> return $ NiceDataSig       r 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.+      -- Need to set updater state to dirty!+      NiceUnquoteDecl r p _ i tc cc x e -> tellDirty $> NiceUnquoteDecl r p AbstractDef i tc cc x e+      NiceUnquoteDef r p _ tc cc x e    -> tellDirty $> NiceUnquoteDef r p AbstractDef tc cc x e+      d@NiceModule{}                 -> return d+      d@NiceModuleMacro{}            -> return d+      d@NicePragma{}                 -> return d+      d@(NiceOpen _ _ directives)              -> do+        whenJust (publicOpen directives) $ lift . declarationWarning . OpenPublicAbstract+        return d+      d@NiceImport{}                 -> return d+      d@NicePatternSyn{}             -> return d+      d@NiceGeneralize{}             -> return d++instance MakeAbstract Clause where+  mkAbstract (Clause x catchall lhs rhs wh with) = do+    Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with++-- | Contents of a @where@ clause are abstract if the parent is.+instance MakeAbstract WhereClause where+  mkAbstract  NoWhere             = return $ NoWhere+  mkAbstract (AnyWhere r ds)      = dirty $ AnyWhere r [Abstract noRange ds]+  mkAbstract (SomeWhere r m a ds) = dirty $ SomeWhere r m a [Abstract noRange ds]++-- | Make a declaration private.+--+-- Andreas, 2012-11-17:+-- Mark computation as 'dirty' if there was a declaration that could be privatized.+-- If no privatization is taking place, we want to complain about 'UselessPrivate'.+--+-- Alternatively, we could only flag 'dirty' if a non-private thing was privatized.+-- Then, nested @private@s would sometimes also be complained about.++class MakePrivate a where+  mkPrivate :: Origin -> UpdaterT Nice a++  default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> UpdaterT Nice a+  mkPrivate o = traverse $ mkPrivate o++instance MakePrivate a => MakePrivate [a]++-- Leads to overlap with 'WhereClause':+-- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where+--   mkPrivate = traverse mkPrivate++instance MakePrivate Access where+  mkPrivate o = \case+    p@PrivateAccess{} -> return p  -- OR? return $ PrivateAccess o+    _                 -> dirty $ PrivateAccess o++instance MakePrivate NiceDeclaration where+  mkPrivate o = \case+      Axiom r p a i rel x e                    -> (\ p -> Axiom r p a i rel x e)                <$> mkPrivate o p+      NiceField r p a i tac x e                -> (\ p -> NiceField r p a i tac x e)            <$> mkPrivate o p+      PrimitiveFunction r p a x e              -> (\ p -> PrimitiveFunction r p a x e)          <$> mkPrivate o p+      NiceMutual r tc cc pc ds                 -> (\ ds-> NiceMutual r tc cc pc ds)             <$> mkPrivate o ds+      NiceLoneConstructor r ds                 -> NiceLoneConstructor r                         <$> mkPrivate o ds+      NiceModule r p a x tel ds                -> (\ p -> NiceModule r p a x tel ds)            <$> mkPrivate o p+      NiceModuleMacro r p x ma op is           -> (\ p -> NiceModuleMacro r p x ma op is)       <$> mkPrivate o p+      FunSig r p a i m rel tc cc x e           -> (\ p -> FunSig r p a i m rel tc cc x e)       <$> mkPrivate o p+      NiceRecSig r p a pc uc x ls t            -> (\ p -> NiceRecSig r p a pc uc x ls t)        <$> mkPrivate o p+      NiceDataSig r p a pc uc x ls t           -> (\ p -> NiceDataSig r p a pc uc x ls t)       <$> mkPrivate o p+      NiceFunClause r p a tc cc catchall d     -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate o p+      NiceUnquoteDecl r p a i tc cc x e        -> (\ p -> NiceUnquoteDecl r p a i tc cc x e)    <$> mkPrivate o p+      NiceUnquoteDef r p a tc cc x e           -> (\ p -> NiceUnquoteDef r p a tc cc x e)       <$> mkPrivate o p+      NicePatternSyn r p x xs p'               -> (\ p -> NicePatternSyn r p x xs p')           <$> mkPrivate o p+      NiceGeneralize r p i tac x t             -> (\ p -> NiceGeneralize r p i tac x t)         <$> mkPrivate o p+      d@NicePragma{}                           -> return d+      d@(NiceOpen _ _ directives)              -> do+        whenJust (publicOpen directives) $ lift . declarationWarning . OpenPublicPrivate+        return d+      d@NiceImport{}                           -> return d+      -- 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 o cls+      d@NiceDataDef{}                          -> return d+      d@NiceRecDef{}                           -> return d++instance MakePrivate Clause where+  mkPrivate o (Clause x catchall lhs rhs wh with) = do+    Clause x catchall lhs rhs <$> mkPrivate o wh <*> mkPrivate o with++instance MakePrivate WhereClause where+  mkPrivate o = \case+    d@NoWhere    -> return d+    -- @where@-declarations are protected behind an anonymous module,+    -- thus, they are effectively private by default.+    d@AnyWhere{} -> return d+    -- Andreas, 2016-07-08+    -- A @where@-module is private if the parent function is private.+    -- The contents of this module are not private, unless declared so!+    -- Thus, we do not recurse into the @ds@ (could not anyway).+    SomeWhere r m a ds -> mkPrivate o a <&> \ a' -> SomeWhere r m a' ds++-- The following function is (at the time of writing) only used three+-- times: for building Lets, and for printing error messages.++-- | (Approximately) convert a 'NiceDeclaration' back to a list of+-- 'Declaration's.+notSoNiceDeclarations :: NiceDeclaration -> [Declaration]+notSoNiceDeclarations = \case+    Axiom _ _ _ i rel x e          -> inst i [TypeSig rel Nothing x e]+    NiceField _ _ _ i tac x argt   -> [FieldSig i tac x argt]+    PrimitiveFunction r _ _ x e    -> [Primitive r [TypeSig (argInfo e) Nothing x (unArg e)]]+    NiceMutual r _ _ _ ds          -> [Mutual r $ concatMap notSoNiceDeclarations ds]+    NiceLoneConstructor r ds       -> [LoneConstructor r $ concatMap notSoNiceDeclarations ds]+    NiceModule r _ _ x tel ds      -> [Module r x tel ds]+    NiceModuleMacro r _ x ma o dir -> [ModuleMacro r x ma o dir]+    NiceOpen r x dir               -> [Open r x dir]+    NiceImport r x as o dir        -> [Import r x as o dir]+    NicePragma _ p                 -> [Pragma p]+    NiceRecSig r _ _ _ _ x bs e    -> [RecordSig r x bs e]+    NiceDataSig r _ _ _ _ x bs e   -> [DataSig r x bs e]+    NiceFunClause _ _ _ _ _ _ d    -> [d]+    FunSig _ _ _ i _ rel _ _ x e   -> inst i [TypeSig rel Nothing x e]+    FunDef _ ds _ _ _ _ _ _        -> ds+    NiceDataDef r _ _ _ _ x bs cs  -> [DataDef r x bs $ concatMap notSoNiceDeclarations cs]+    NiceRecDef r _ _ _ _ x dir bs ds -> [RecordDef r x dir bs ds]+    NicePatternSyn r _ n as p      -> [PatternSyn r n as p]+    NiceGeneralize r _ i tac n e   -> [Generalize r [TypeSig i tac n e]]+    NiceUnquoteDecl r _ _ i _ _ x e -> inst i [UnquoteDecl r x e]+    NiceUnquoteDef r _ _ _ _ x e    -> [UnquoteDef r x e]+  where+    inst (InstanceDef r) ds = [InstanceB r ds]+    inst NotInstanceDef  ds = ds++-- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?+niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract+niceHasAbstract = \case+    Axiom{}                       -> Nothing+    NiceField _ _ a _ _ _ _       -> Just a+    PrimitiveFunction _ _ a _ _   -> Just a+    NiceMutual{}                  -> Nothing+    NiceLoneConstructor{}         -> Nothing+    NiceModule _ _ a _ _ _        -> Just a+    NiceModuleMacro{}             -> Nothing+    NiceOpen{}                    -> Nothing+    NiceImport{}                  -> Nothing+    NicePragma{}                  -> Nothing+    NiceRecSig{}                  -> Nothing+    NiceDataSig{}                 -> Nothing+    NiceFunClause _ _ a _ _ _ _   -> Just a+    FunSig{}                      -> Nothing+    FunDef _ _ a _ _ _ _ _        -> Just a+    NiceDataDef _ _ a _ _ _ _ _   -> Just a+    NiceRecDef _ _ a _ _ _ _ _ _ -> Just a     NicePatternSyn{}              -> Nothing     NiceGeneralize{}              -> Nothing     NiceUnquoteDecl _ _ a _ _ _ _ _ -> Just a

+ src/full/Agda/Syntax/Concrete/Definitions/Errors.hs view

@@ -0,0 +1,364 @@+module Agda.Syntax.Concrete.Definitions.Errors where++import Control.DeepSeq++import Data.Data++import GHC.Generics (Generic)++import Agda.Syntax.Position+import Agda.Syntax.Concrete+import Agda.Syntax.Concrete.Name+import Agda.Syntax.Concrete.Definitions.Types++import Agda.Interaction.Options.Warnings++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.Pretty++------------------------------------------------------------------------+-- Errors++-- | Exception with internal source code callstack+data DeclarationException = DeclarationException+  { deLocation  :: CallStack+  , deException :: DeclarationException'+  }++-- | The exception type.+data DeclarationException'+  = MultipleEllipses Pattern+  | InvalidName Name+  | DuplicateDefinition Name+  | DuplicateAnonDeclaration Range+  | MissingWithClauses Name LHS+  | WrongDefinition Name DataRecOrFun DataRecOrFun+  | DeclarationPanic String+  | WrongContentBlock KindOfBlock Range+  | AmbiguousFunClauses LHS (List1 Name)+      -- ^ In a mutual block, a clause could belong to any of the ≥2 type signatures ('Name').+  | AmbiguousConstructor Range Name [Name]+      -- ^ In an interleaved mutual block, a constructor could belong to any of the data signatures ('Name')+  | InvalidMeasureMutual Range+      -- ^ In a mutual block, all or none need a MEASURE pragma.+      --   Range is of mutual block.+  | UnquoteDefRequiresSignature (List1 Name)+  | BadMacroDef NiceDeclaration+    deriving (Data, Show)++------------------------------------------------------------------------+-- Warnings++data DeclarationWarning = DeclarationWarning+  { dwLocation :: CallStack+  , dwWarning  :: DeclarationWarning'+  } deriving (Show, Generic)++-- | Non-fatal errors encountered in the Nicifier.+data DeclarationWarning'+  -- Please keep in alphabetical order.+  = EmptyAbstract Range    -- ^ Empty @abstract@  block.+  | EmptyConstructor Range -- ^ Empty @constructor@ block.+  | EmptyField Range       -- ^ Empty @field@     block.+  | EmptyGeneralize Range  -- ^ Empty @variable@  block.+  | EmptyInstance Range    -- ^ Empty @instance@  block+  | EmptyMacro Range       -- ^ Empty @macro@     block.+  | EmptyMutual Range      -- ^ Empty @mutual@    block.+  | EmptyPostulate Range   -- ^ Empty @postulate@ block.+  | EmptyPrivate Range     -- ^ Empty @private@   block.+  | EmptyPrimitive Range   -- ^ Empty @primitive@ block.+  | InvalidCatchallPragma Range+      -- ^ A {-\# CATCHALL \#-} pragma+      --   that does not precede a function clause.+  | InvalidConstructor Range+      -- ^ Invalid definition in a constructor block+  | InvalidConstructorBlock Range+      -- ^ Invalid constructor block (not inside an interleaved mutual block)+  | InvalidCoverageCheckPragma Range+      -- ^ A {-\# NON_COVERING \#-} pragma that does not apply to any function.+  | InvalidNoPositivityCheckPragma Range+      -- ^ A {-\# NO_POSITIVITY_CHECK \#-} pragma+      --   that does not apply to any data or record type.+  | InvalidNoUniverseCheckPragma Range+      -- ^ A {-\# NO_UNIVERSE_CHECK \#-} pragma+      --   that does not apply to a data or record type.+  | InvalidRecordDirective Range+      -- ^ A record directive outside of a record / below existing fields.+  | InvalidTerminationCheckPragma Range+      -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma+      --   that does not apply to any function.+  | MissingDefinitions [(Name, Range)]+      -- ^ Declarations (e.g. type signatures) without a definition.+  | NotAllowedInMutual Range String+  | OpenPublicPrivate Range+      -- ^ @private@ has no effect on @open public@.  (But the user might think so.)+  | OpenPublicAbstract Range+      -- ^ @abstract@ has no effect on @open public@.  (But the user might think so.)+  | PolarityPragmasButNotPostulates [Name]+  | PragmaNoTerminationCheck Range+  -- ^ Pragma @{-\# NO_TERMINATION_CHECK \#-}@ has been replaced+  --   by @{-\# TERMINATING \#-}@ and @{-\# NON_TERMINATING \#-}@.+  | PragmaCompiled Range+  -- ^ @COMPILE@ pragmas are not allowed in safe mode+  | ShadowingInTelescope (List1 (Name, List2 Range))+  | UnknownFixityInMixfixDecl [Name]+  | UnknownNamesInFixityDecl [Name]+  | UnknownNamesInPolarityPragmas [Name]+  | UselessAbstract Range+      -- ^ @abstract@ block with nothing that can (newly) be made abstract.+  | UselessInstance Range+      -- ^ @instance@ block with nothing that can (newly) become an instance.+  | UselessPrivate Range+      -- ^ @private@ block with nothing that can (newly) be made private.+  deriving (Data, Show, Generic)++declarationWarningName :: DeclarationWarning -> WarningName+declarationWarningName = declarationWarningName' . dwWarning++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_+  InvalidCatchallPragma{}           -> InvalidCatchallPragma_+  InvalidConstructor{}              -> InvalidConstructor_+  InvalidConstructorBlock{}         -> InvalidConstructorBlock_+  InvalidNoPositivityCheckPragma{}  -> InvalidNoPositivityCheckPragma_+  InvalidNoUniverseCheckPragma{}    -> InvalidNoUniverseCheckPragma_+  InvalidRecordDirective{}          -> InvalidRecordDirective_+  InvalidTerminationCheckPragma{}   -> InvalidTerminationCheckPragma_+  InvalidCoverageCheckPragma{}      -> InvalidCoverageCheckPragma_+  MissingDefinitions{}              -> MissingDefinitions_+  NotAllowedInMutual{}              -> NotAllowedInMutual_+  OpenPublicPrivate{}               -> OpenPublicPrivate_+  OpenPublicAbstract{}              -> OpenPublicAbstract_+  PolarityPragmasButNotPostulates{} -> PolarityPragmasButNotPostulates_+  PragmaNoTerminationCheck{}        -> PragmaNoTerminationCheck_+  PragmaCompiled{}                  -> PragmaCompiled_+  ShadowingInTelescope{}            -> ShadowingInTelescope_+  UnknownFixityInMixfixDecl{}       -> UnknownFixityInMixfixDecl_+  UnknownNamesInFixityDecl{}        -> UnknownNamesInFixityDecl_+  UnknownNamesInPolarityPragmas{}   -> UnknownNamesInPolarityPragmas_+  UselessAbstract{}                 -> UselessAbstract_+  UselessInstance{}                 -> UselessInstance_+  UselessPrivate{}                  -> UselessPrivate_++-- | Nicifier warnings turned into errors in @--safe@ mode.+unsafeDeclarationWarning :: DeclarationWarning -> Bool+unsafeDeclarationWarning = unsafeDeclarationWarning' . dwWarning++unsafeDeclarationWarning' :: DeclarationWarning' -> Bool+unsafeDeclarationWarning' = \case+  -- Please keep in alphabetical order.+  EmptyAbstract{}                   -> False+  EmptyConstructor{}                -> False+  EmptyField{}                      -> False+  EmptyGeneralize{}                 -> False+  EmptyInstance{}                   -> False+  EmptyMacro{}                      -> False+  EmptyMutual{}                     -> False+  EmptyPrivate{}                    -> False+  EmptyPostulate{}                  -> False+  EmptyPrimitive{}                  -> False+  InvalidCatchallPragma{}           -> False+  InvalidConstructor{}              -> False+  InvalidConstructorBlock{}         -> False+  InvalidNoPositivityCheckPragma{}  -> False+  InvalidNoUniverseCheckPragma{}    -> False+  InvalidRecordDirective{}          -> False+  InvalidTerminationCheckPragma{}   -> False+  InvalidCoverageCheckPragma{}      -> False+  MissingDefinitions{}              -> True  -- not safe+  NotAllowedInMutual{}              -> False -- really safe?+  OpenPublicPrivate{}               -> False+  OpenPublicAbstract{}              -> False+  PolarityPragmasButNotPostulates{} -> False+  PragmaNoTerminationCheck{}        -> True  -- not safe+  PragmaCompiled{}                  -> True  -- not safe+  ShadowingInTelescope{}            -> False+  UnknownFixityInMixfixDecl{}       -> False+  UnknownNamesInFixityDecl{}        -> False+  UnknownNamesInPolarityPragmas{}   -> False+  UselessAbstract{}                 -> False+  UselessInstance{}                 -> False+  UselessPrivate{}                  -> False++------------------------------------------------------------------------+-- Instances++instance HasRange DeclarationException where+  getRange (DeclarationException _ err) = getRange err++instance HasRange DeclarationException' where+  getRange (MultipleEllipses d)                 = getRange d+  getRange (InvalidName x)                      = getRange x+  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 (DeclarationPanic _)                 = noRange+  getRange (WrongContentBlock _ r)              = r+  getRange (InvalidMeasureMutual r)             = r+  getRange (UnquoteDefRequiresSignature x)      = getRange x+  getRange (BadMacroDef d)                      = getRange d++instance HasRange DeclarationWarning where+  getRange (DeclarationWarning _ w) = getRange w++instance HasRange DeclarationWarning' where+  getRange (UnknownNamesInFixityDecl xs)        = getRange xs+  getRange (UnknownFixityInMixfixDecl xs)       = getRange xs+  getRange (UnknownNamesInPolarityPragmas xs)   = getRange xs+  getRange (PolarityPragmasButNotPostulates xs) = getRange xs+  getRange (MissingDefinitions xs)              = getRange xs+  getRange (UselessPrivate r)                   = r+  getRange (NotAllowedInMutual r x)             = r+  getRange (UselessAbstract r)                  = r+  getRange (UselessInstance r)                  = r+  getRange (EmptyConstructor r)                 = r+  getRange (EmptyMutual r)                      = r+  getRange (EmptyAbstract r)                    = r+  getRange (EmptyPrivate r)                     = r+  getRange (EmptyInstance r)                    = r+  getRange (EmptyMacro r)                       = r+  getRange (EmptyPostulate r)                   = r+  getRange (EmptyGeneralize r)                  = r+  getRange (EmptyPrimitive r)                   = r+  getRange (EmptyField r)                       = r+  getRange (InvalidTerminationCheckPragma r)    = r+  getRange (InvalidCoverageCheckPragma r)       = r+  getRange (InvalidNoPositivityCheckPragma r)   = r+  getRange (InvalidCatchallPragma r)            = r+  getRange (InvalidConstructor r)               = r+  getRange (InvalidConstructorBlock r)          = r+  getRange (InvalidNoUniverseCheckPragma r)     = r+  getRange (InvalidRecordDirective r)           = r+  getRange (PragmaNoTerminationCheck r)         = r+  getRange (PragmaCompiled r)                   = r+  getRange (OpenPublicAbstract r)               = r+  getRange (OpenPublicPrivate r)                = r+  getRange (ShadowingInTelescope ns)            = getRange ns++-- These error messages can (should) be terminated by a dot ".",+-- there is no error context printed after them.+instance Pretty DeclarationException' where+  pretty (MultipleEllipses p) = fsep $+    pwords "Multiple ellipses in left-hand side" ++ [pretty p]+  pretty (InvalidName x) = fsep $+    pwords "Invalid name:" ++ [pretty x]+  pretty (DuplicateDefinition x) = fsep $+    pwords "Duplicate definition of" ++ [pretty x]+  pretty (DuplicateAnonDeclaration _) = fsep $+    pwords "Duplicate declaration of _"+  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 (AmbiguousConstructor _ n ns) = sep+    [ fsep (pwords "Could not find a matching data signature for constructor " ++ [pretty n])+    , vcat (case ns of+              [] -> [fsep $ pwords "There was no candidate."]+              _  -> fsep (pwords "It could be any of:") : fmap (pretty . PrintRange) ns+           )+    ]+  pretty (WrongContentBlock b _)      = fsep . pwords $+    case b of+      PostulateBlock -> "A postulate block can only contain type signatures, possibly under keyword instance"+      DataBlock -> "A data definition can only contain type signatures, possibly under keyword instance"+      _ -> "Unexpected declaration"+  pretty (InvalidMeasureMutual _) = fsep $+    pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma."+  pretty (UnquoteDefRequiresSignature xs) = fsep $+    pwords "Missing type signatures for unquoteDef" ++ map pretty (List1.toList xs)+  pretty (BadMacroDef nd) = fsep $+    text (declName nd) : pwords "are not allowed in macro blocks"+  pretty (DeclarationPanic s) = text s++instance Pretty DeclarationWarning where+  pretty (DeclarationWarning _ w) = pretty w++instance Pretty DeclarationWarning' where+  pretty (UnknownNamesInFixityDecl xs) = fsep $+    pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):"+    ++ punctuate comma (map pretty xs)+  pretty (UnknownFixityInMixfixDecl xs) = fsep $+    pwords "The following mixfix names do not have an associated fixity declaration:"+    ++ punctuate comma (map pretty xs)+  pretty (UnknownNamesInPolarityPragmas xs) = fsep $+    pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):"+    ++ punctuate comma  (map pretty xs)+  pretty (MissingDefinitions xs) = fsep $+   pwords "The following names are declared but not accompanied by a definition:"+   ++ punctuate comma (map (pretty . fst) xs)+  pretty (NotAllowedInMutual r nd) = fsep $+    text nd : pwords "in mutual blocks are not supported.  Suggestion: get rid of the mutual block by manually ordering declarations"+  pretty (PolarityPragmasButNotPostulates xs) = fsep $+    pwords "Polarity pragmas have been given for the following identifiers which are not postulates:"+    ++ punctuate comma (map pretty xs)+  pretty (UselessPrivate _)      = fsep $+    pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."+  pretty (UselessAbstract _)      = fsep $+    pwords "Using abstract here has no effect. Abstract applies to only definitions like data definitions, record type definitions and function clauses."+  pretty (UselessInstance _)      = fsep $+    pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."+  pretty (EmptyMutual    _)  = fsep $ pwords "Empty mutual block."+  pretty EmptyConstructor{}  = fsep $ pwords "Empty constructor block."+  pretty (EmptyAbstract  _)  = fsep $ pwords "Empty abstract block."+  pretty (EmptyPrivate   _)  = fsep $ pwords "Empty private block."+  pretty (EmptyInstance  _)  = fsep $ pwords "Empty instance block."+  pretty (EmptyMacro     _)  = fsep $ pwords "Empty macro block."+  pretty (EmptyPostulate _)  = fsep $ pwords "Empty postulate block."+  pretty (EmptyGeneralize _) = fsep $ pwords "Empty variable block."+  pretty (EmptyPrimitive _)  = fsep $ pwords "Empty primitive block."+  pretty (EmptyField _)      = fsep $ pwords "Empty field block."+  pretty InvalidRecordDirective{} = fsep $+    pwords "Record directives can only be used inside record definitions and before field declarations."+  pretty (InvalidTerminationCheckPragma _) = fsep $+    pwords "Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."+  pretty InvalidConstructor{} = fsep $+    pwords "`constructor' blocks may only contain type signatures for constructors."+  pretty InvalidConstructorBlock{} = fsep $+    pwords "No `constructor' blocks outside of `interleaved mutual' blocks."+  pretty (InvalidCoverageCheckPragma _)    = fsep $+    pwords "Coverage checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."+  pretty (InvalidNoPositivityCheckPragma _) = fsep $+    pwords "NO_POSITIVITY_CHECKING pragmas can only precede a data/record definition or a mutual block (that contains a data/record definition)."+  pretty (InvalidCatchallPragma _) = fsep $+    pwords "The CATCHALL pragma can only precede a function clause."+  pretty (InvalidNoUniverseCheckPragma _) = fsep $+    pwords "NO_UNIVERSE_CHECKING pragmas can only precede a data/record definition."+  pretty (PragmaNoTerminationCheck _) = fsep $+    pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed.  To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."+  pretty (PragmaCompiled _) = fsep $+    pwords "COMPILE pragma not allowed in safe mode."+  pretty (OpenPublicAbstract _) = fsep $+    pwords "public does not have any effect in an abstract block."+  pretty (OpenPublicPrivate _) = fsep $+    pwords "public does not have any effect in a private block."+  pretty (ShadowingInTelescope nrs) = fsep $+    pwords "Shadowing in telescope, repeated variable names:"+    ++ punctuate comma (fmap (pretty . fst) nrs)++instance NFData DeclarationWarning+instance NFData DeclarationWarning'

+ src/full/Agda/Syntax/Concrete/Definitions/Monad.hs view

@@ -0,0 +1,248 @@+module Agda.Syntax.Concrete.Definitions.Monad where++import Control.Monad.Except+import Control.Monad.State++import Data.Bifunctor (second)+import Data.Map (Map)+import qualified Data.Map as Map++import Agda.Syntax.Position+import Agda.Syntax.Common hiding (TerminationCheck())+import Agda.Syntax.Concrete.Name+import Agda.Syntax.Concrete.Definitions.Types+import Agda.Syntax.Concrete.Definitions.Errors++import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.Lens++-- | Nicifier monad.+--   Preserve the state when throwing an exception.++newtype Nice a = Nice { unNice :: ExceptT DeclarationException (State NiceEnv) a }+  deriving ( Functor, Applicative, Monad+           , MonadState NiceEnv, MonadError DeclarationException+           )++-- | Run a Nicifier computation, return result and warnings+--   (in chronological order).+runNice :: Nice a -> (Either DeclarationException a, NiceWarnings)+runNice m = second (reverse . niceWarn) $+  runExceptT (unNice m) `runState` initNiceEnv++-- | Nicifier state.++data NiceEnv = NiceEnv+  { _loneSigs :: LoneSigs+    -- ^ Lone type signatures that wait for their definition.+  , _termChk  :: TerminationCheck+    -- ^ Termination checking pragma waiting for a definition.+  , _posChk   :: PositivityCheck+    -- ^ Positivity checking pragma waiting for a definition.+  , _uniChk   :: UniverseCheck+    -- ^ Universe checking pragma waiting for a data/rec signature or definition.+  , _catchall :: Catchall+    -- ^ Catchall pragma waiting for a function clause.+  , _covChk  :: CoverageCheck+    -- ^ Coverage pragma waiting for a definition.+  , niceWarn :: NiceWarnings+    -- ^ Stack of warnings. Head is last warning.+  , _nameId  :: NameId+    -- ^ We distinguish different 'NoName's (anonymous definitions) by a unique 'NameId'.+  }++data LoneSig = LoneSig+  { loneSigRange :: Range+  , loneSigName  :: Name+      -- ^ If 'isNoName', this name can have a different 'NameId'+      --   than the key of 'LoneSigs' pointing to it.+  , loneSigKind  :: DataRecOrFun+  }++type LoneSigs     = Map Name LoneSig+     -- ^ We retain the 'Name' also in the codomain since+     --   'Name' as a key is up to @Eq Name@ which ignores the range.+     --   However, without range names are not unique in case the+     --   user gives a second definition of the same name.+     --   This causes then problems in 'replaceSigs' which might+     --   replace the wrong signature.+     --+     --   Another reason is that we want to distinguish different+     --   occurrences of 'NoName' in a mutual block (issue #4157).+     --   The 'NoName' in the codomain will have a unique 'NameId'.++type NiceWarnings = [DeclarationWarning]+     -- ^ Stack of warnings. Head is last warning.++-- | Initial nicifier state.++initNiceEnv :: NiceEnv+initNiceEnv = NiceEnv+  { _loneSigs = Map.empty+  , _termChk  = TerminationCheck+  , _posChk   = YesPositivityCheck+  , _uniChk   = YesUniverseCheck+  , _catchall = False+  , _covChk   = YesCoverageCheck+  , niceWarn  = []+  , _nameId   = NameId 1 noModuleNameHash+  }++lensNameId :: Lens' NameId NiceEnv+lensNameId f e = f (_nameId e) <&> \ i -> e { _nameId = i }++nextNameId :: Nice NameId+nextNameId = do+  i <- use lensNameId+  lensNameId %= succ+  return i++-- * Handling the lone signatures, stored to infer mutual blocks.++-- | Lens for field '_loneSigs'.++loneSigs :: Lens' LoneSigs NiceEnv+loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }++-- | Adding a lone signature to the state.+--   Return the name (which is made unique if 'isNoName').++addLoneSig :: Range -> Name -> DataRecOrFun -> Nice Name+addLoneSig r x k = do+  -- Andreas, 2020-05-19, issue #4157, make '_' unique.+  x' <- if not $ isNoName x then return x else do+    i <- nextNameId+    return x{ nameId = i }+  loneSigs %== \ s -> do+    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+  return x'++-- | Remove a lone signature from the state.++removeLoneSig :: Name -> Nice ()+removeLoneSig x = loneSigs %= Map.delete x++-- | Search for forward type signature.++getSig :: Name -> Nice (Maybe DataRecOrFun)+getSig x = fmap loneSigKind . Map.lookup x <$> use loneSigs++-- | Check that no lone signatures are left in the state.++noLoneSigs :: Nice Bool+noLoneSigs = null <$> use loneSigs++-- | Ensure that all forward declarations have been given a definition.++forgetLoneSigs :: Nice ()+forgetLoneSigs = loneSigs .= Map.empty++checkLoneSigs :: LoneSigs -> Nice ()+checkLoneSigs xs = do+  forgetLoneSigs+  unless (Map.null xs) $ declarationWarning $ MissingDefinitions $+    map (\s -> (loneSigName s , loneSigRange s)) $ Map.elems xs++-- | Get names of lone function signatures, plus their unique names.++loneFuns :: LoneSigs -> [(Name,Name)]+loneFuns = map (second loneSigName) . filter (isFunName . loneSigKind . snd) . Map.toList++-- | Create a 'LoneSigs' map from an association list.++loneSigsFromLoneNames :: [(Range, Name, DataRecOrFun)] -> LoneSigs+loneSigsFromLoneNames = Map.fromList . map (\(r,x,k) -> (x, LoneSig r x k))++-- | Lens for field '_termChk'.++terminationCheckPragma :: Lens' TerminationCheck NiceEnv+terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }++withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a+withTerminationCheckPragma tc f = do+  tc_old <- use terminationCheckPragma+  terminationCheckPragma .= tc+  result <- f+  terminationCheckPragma .= tc_old+  return result++coverageCheckPragma :: Lens' CoverageCheck NiceEnv+coverageCheckPragma f e = f (_covChk e) <&> \ s -> e { _covChk = s }++withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a+withCoverageCheckPragma tc f = do+  tc_old <- use coverageCheckPragma+  coverageCheckPragma .= tc+  result <- f+  coverageCheckPragma .= tc_old+  return result++-- | Lens for field '_posChk'.++positivityCheckPragma :: Lens' PositivityCheck NiceEnv+positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }++withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a+withPositivityCheckPragma pc f = do+  pc_old <- use positivityCheckPragma+  positivityCheckPragma .= pc+  result <- f+  positivityCheckPragma .= pc_old+  return result++-- | Lens for field '_uniChk'.++universeCheckPragma :: Lens' UniverseCheck NiceEnv+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'.++getUniverseCheckFromSig :: Name -> Nice UniverseCheck+getUniverseCheckFromSig x = maybe YesUniverseCheck universeCheck <$> getSig x++-- | Lens for field '_catchall'.++catchallPragma :: Lens' Catchall NiceEnv+catchallPragma f e = f (_catchall e) <&> \ s -> e { _catchall = s }++-- | Get current catchall pragma, and reset it for the next clause.++popCatchallPragma :: Nice Catchall+popCatchallPragma = do+  ca <- use catchallPragma+  catchallPragma .= False+  return ca++withCatchallPragma :: Catchall -> Nice a -> Nice a+withCatchallPragma ca f = do+  ca_old <- use catchallPragma+  catchallPragma .= ca+  result <- f+  catchallPragma .= ca_old+  return result++-- | Add a new warning.+niceWarning :: DeclarationWarning -> Nice ()+niceWarning w = modify $ \ st -> st { niceWarn = w : niceWarn st }++declarationException :: HasCallStack => DeclarationException' -> Nice a+declarationException e = withCallerCallStack $ throwError . flip DeclarationException e++declarationWarning' :: DeclarationWarning' -> CallStack -> Nice ()+declarationWarning' w loc = niceWarning $ DeclarationWarning loc w++declarationWarning :: HasCallStack => DeclarationWarning' -> Nice ()+declarationWarning = withCallerCallStack . declarationWarning'

+ src/full/Agda/Syntax/Concrete/Definitions/Types.hs view

@@ -0,0 +1,315 @@+module Agda.Syntax.Concrete.Definitions.Types where++import Control.DeepSeq++import Data.Data+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.Concrete+import Agda.Syntax.Concrete.Name+import Agda.Syntax.Concrete.Pretty++import Agda.Utils.Pretty+import Agda.Utils.Impossible++{--------------------------------------------------------------------------+    Types+ --------------------------------------------------------------------------}++{-| The nice declarations. No fixity declarations and function definitions are+    contained in a single constructor instead of spread out between type+    signatures and clauses. The @private@, @postulate@, @abstract@ and @instance@+    modifiers have been distributed to the individual declarations.++    Observe the order of components:++      Range+      Fixity'+      Access+      IsAbstract+      IsInstance+      TerminationCheck+      PositivityCheck++      further attributes++      (Q)Name++      content (Expr, Declaration ...)+-}+data NiceDeclaration+  = Axiom Range Access IsAbstract IsInstance ArgInfo Name Expr+      -- ^ 'IsAbstract' argument: We record whether a declaration was made in an @abstract@ block.+      --+      --   'ArgInfo' argument: Axioms and functions can be declared irrelevant.+      --   ('Hiding' should be 'NotHidden'.)+  | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr)+  | PrimitiveFunction Range Access IsAbstract Name (Arg Expr)+  | NiceMutual Range TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration]+  | NiceModule Range Access IsAbstract QName Telescope [Declaration]+  | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective+  | NiceOpen Range QName ImportDirective+  | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective+  | NicePragma Range Pragma+  | NiceRecSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] Expr+  | NiceDataSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] 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]+      -- ^ 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]+  | NiceLoneConstructor Range [NiceConstructor]+  | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name RecordDirectives [LamBinding] [Declaration]+      -- ^ @(Maybe Range)@ gives range of the 'pattern' declaration.+  | NicePatternSyn Range Access Name [Arg Name] Pattern+  | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr+  | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr+  | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr+  deriving (Data, Show, Generic)++instance NFData NiceDeclaration++type TerminationCheck = Common.TerminationCheck Measure++-- | Termination measure is, for now, a variable name.+type Measure = Name++type Catchall = Bool++-- | Only 'Axiom's.+type NiceConstructor = NiceTypeSignature++-- | Only 'Axiom's.+type NiceTypeSignature  = NiceDeclaration++-- | One clause in a function definition. There is no guarantee that the 'LHS'+--   actually declares the 'Name'. We will have to check that later.+data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]+    deriving (Data, Show, Generic)++instance NFData Clause++-- | When processing a mutual block we collect the various checks present in the block+--   before combining them.++data MutualChecks = MutualChecks+  { mutualTermination :: [TerminationCheck]+  , mutualCoverage    :: [CoverageCheck]+  , mutualPositivity  :: [PositivityCheck]+  }++instance Semigroup MutualChecks where+  MutualChecks a b c <> MutualChecks a' b' c'+    = MutualChecks (a <> a') (b <> b') (c <> c')++instance Monoid MutualChecks where+  mempty = MutualChecks [] [] []+  mappend = (<>)++-- | In an inferred `mutual' block we keep accumulating nice declarations until all+--   of the lone signatures have an attached definition. The type is therefore a bit+--   span-like: we return an initial segment (the inferred mutual block) together+--   with leftovers.++data InferredMutual = InferredMutual+  { inferredChecks    :: MutualChecks       -- checks for this block+  , inferredBlock     :: [NiceDeclaration]  -- mutual block+  , inferredLeftovers :: [NiceDeclaration]  -- leftovers+  }++extendInferredBlock :: NiceDeclaration -> InferredMutual -> InferredMutual+extendInferredBlock d (InferredMutual cs ds left) = InferredMutual cs (d : ds) left++-- | In an `interleaved mutual' block we collect the data signatures, function signatures,+--   as well as their associated constructors and function clauses respectively.+--   Each signature is given a position in the block (from 0 onwards) and each set+--   of constructor / clauses is given a *distinct* one. This allows for interleaved+--   forward declarations similar to what one gets in a new-style mutual block.+type InterleavedMutual = Map Name InterleavedDecl++data InterleavedDecl+  = InterleavedData+    { infixDataSig  :: (Int, NiceDeclaration)           -- a data signature+    , infixDataCons :: Maybe (Int, [[NiceConstructor]]) -- and associated constructors+    }+  | InterleavedFun+    { infixFunSig     :: (Int, NiceDeclaration)                  -- a fun signature+    , infixFunClauses :: Maybe (Int, [([Declaration],[Clause])]) -- and associated fun clauses+    }++isInterleavedFun :: InterleavedDecl -> Maybe ()+isInterleavedFun InterleavedFun{} = Just ()+isInterleavedFun _ = Nothing++isInterleavedData :: InterleavedDecl -> Maybe ()+isInterleavedData InterleavedData{} = Just ()+isInterleavedData _ = Nothing++interleavedDecl :: Name -> InterleavedDecl -> [(Int, NiceDeclaration)]+interleavedDecl k = \case+  InterleavedData (i, d@(NiceDataSig _ acc abs pc uc _ pars _)) ds ->+    let fpars = concatMap dropTypeAndModality pars+        ddef  = NiceDataDef noRange UserWritten abs pc uc k fpars+    in (i,d) : maybe [] (\ (j, dss) -> [(j, ddef (concat (reverse dss)))]) ds+  InterleavedFun (i, d@(FunSig r acc abs inst mac info tc cc n e)) dcs ->+    let fdef dcss = let (dss, css) = unzip dcss in+                    FunDef r (concat dss) abs inst tc cc n (concat css)+    in (i,d) : maybe [] (\ (j, dcss) -> [(j, fdef (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).+  | ConstructorBlock  -- ^ @constructor@, in @interleaved mutual@.+  deriving (Data, Eq, Ord, Show)+++instance HasRange NiceDeclaration where+  getRange (Axiom r _ _ _ _ _ _)           = r+  getRange (NiceField r _ _ _ _ _ _)       = r+  getRange (NiceMutual r _ _ _ _)          = r+  getRange (NiceModule r _ _ _ _ _ )       = r+  getRange (NiceModuleMacro r _ _ _ _ _)   = r+  getRange (NiceOpen r _ _)                = r+  getRange (NiceImport r _ _ _ _)          = r+  getRange (NicePragma r _)                = r+  getRange (PrimitiveFunction r _ _ _ _)   = r+  getRange (FunSig r _ _ _ _ _ _ _ _ _)    = r+  getRange (FunDef r _ _ _ _ _ _ _)        = r+  getRange (NiceDataDef r _ _ _ _ _ _ _)   = r+  getRange (NiceLoneConstructor r _)       = r+  getRange (NiceRecDef r _ _ _ _ _ _ _ _)  = r+  getRange (NiceRecSig r _ _ _ _ _ _ _)    = r+  getRange (NiceDataSig r _ _ _ _ _ _ _)   = r+  getRange (NicePatternSyn r _ _ _ _)      = r+  getRange (NiceGeneralize r _ _ _ _ _)    = r+  getRange (NiceFunClause r _ _ _ _ _ _)   = r+  getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r+  getRange (NiceUnquoteDef r _ _ _ _ _ _)    = r++instance Pretty NiceDeclaration where+  pretty = \case+    Axiom _ _ _ _ _ x _            -> text "postulate" <+> pretty x <+> colon <+> text "_"+    NiceField _ _ _ _ _ x _        -> text "field" <+> pretty x+    PrimitiveFunction _ _ _ x _    -> text "primitive" <+> pretty x+    NiceMutual{}                   -> text "mutual"+    NiceModule _ _ _ x _ _         -> text "module" <+> pretty x <+> text "where"+    NiceModuleMacro _ _ x _ _ _    -> text "module" <+> pretty x <+> text "= ..."+    NiceOpen _ x _                 -> text "open" <+> pretty x+    NiceImport _ x _ _ _           -> text "import" <+> pretty x+    NicePragma{}                   -> text "{-# ... #-}"+    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 _ ds       -> text "constructor"+    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>"++declName :: NiceDeclaration -> String+declName Axiom{}             = "Postulates"+declName NiceField{}         = "Fields"+declName NiceMutual{}        = "Mutual blocks"+declName NiceModule{}        = "Modules"+declName NiceModuleMacro{}   = "Modules"+declName NiceOpen{}          = "Open declarations"+declName NiceImport{}        = "Import statements"+declName NicePragma{}        = "Pragmas"+declName PrimitiveFunction{} = "Primitive declarations"+declName NicePatternSyn{}    = "Pattern synonyms"+declName NiceGeneralize{}    = "Generalized variables"+declName NiceUnquoteDecl{}   = "Unquoted declarations"+declName NiceUnquoteDef{}    = "Unquoted definitions"+declName NiceRecSig{}        = "Records"+declName NiceDataSig{}       = "Data types"+declName NiceFunClause{}     = "Functions without a type signature"+declName FunSig{}            = "Type signatures"+declName FunDef{}            = "Function definitions"+declName NiceRecDef{}        = "Records"+declName NiceDataDef{}       = "Data types"+declName NiceLoneConstructor{} = "Constructors"+++data InMutual+  = InMutual    -- ^ we are nicifying a mutual block+  | NotInMutual -- ^ we are nicifying decls not in a mutual block+    deriving (Eq, Show)++-- | The kind of the forward declaration.++data DataRecOrFun+  = DataName+    { _kindPosCheck :: PositivityCheck+    , _kindUniCheck :: UniverseCheck+    }+    -- ^ Name of a data type+  | RecName+    { _kindPosCheck :: PositivityCheck+    , _kindUniCheck :: UniverseCheck+    }+    -- ^ Name of a record type+  | FunName TerminationCheck CoverageCheck+    -- ^ Name of a function.+  deriving (Data, Show)++-- Ignore pragmas when checking equality+instance Eq DataRecOrFun where+  DataName{} == DataName{} = True+  RecName{}  == RecName{}  = True+  FunName{}  == FunName{}  = True+  _          == _          = False++instance Pretty DataRecOrFun where+  pretty DataName{} = "data type"+  pretty RecName{}  = "record type"+  pretty FunName{}  = "function"++isFunName :: DataRecOrFun -> Bool+isFunName (FunName{}) = True+isFunName _           = False++sameKind :: DataRecOrFun -> DataRecOrFun -> Bool+sameKind = (==)++terminationCheck :: DataRecOrFun -> TerminationCheck+terminationCheck (FunName tc _) = tc+terminationCheck _ = TerminationCheck++coverageCheck :: DataRecOrFun -> CoverageCheck+coverageCheck (FunName _ cc) = cc+coverageCheck _ = YesCoverageCheck++positivityCheck :: DataRecOrFun -> PositivityCheck+positivityCheck (DataName pc _) = pc+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

src/full/Agda/Syntax/Concrete/Fixity.hs view

@@ -8,6 +8,7 @@   ) where  import Prelude hiding (null)+ import Control.Monad import Data.Map (Map) import qualified Data.Map as Map@@ -17,15 +18,15 @@ import Data.Semigroup #endif -import Agda.Syntax.Builtin (builtinsNoDef)+import Agda.Syntax.Builtin (isBuiltinNoDef) import Agda.Syntax.Common import Agda.Syntax.Concrete-import Agda.Syntax.Fixity-import Agda.Syntax.Notation import Agda.Syntax.Position import Agda.TypeChecking.Positivity.Occurrence (Occurrence) +import Agda.Utils.CallStack (HasCallStack) import Agda.Utils.Functor+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null import Agda.Utils.Impossible @@ -36,10 +37,10 @@ class Monad m => MonadFixityError m where   throwMultipleFixityDecls            :: [(Name, [Fixity'])] -> m a   throwMultiplePolarityPragmas        :: [Name] -> m a-  warnUnknownNamesInFixityDecl        :: [Name] -> m ()-  warnUnknownNamesInPolarityPragmas   :: [Name] -> m ()-  warnUnknownFixityInMixfixDecl       :: [Name] -> m ()-  warnPolarityPragmasButNotPostulates :: [Name] -> m ()+  warnUnknownNamesInFixityDecl        :: HasCallStack => [Name] -> m ()+  warnUnknownNamesInPolarityPragmas   :: HasCallStack => [Name] -> m ()+  warnUnknownFixityInMixfixDecl       :: HasCallStack => [Name] -> m ()+  warnPolarityPragmasButNotPostulates :: HasCallStack => [Name] -> m ()  -- | Add more fixities. Throw an exception for multiple fixity declarations. --   OR:  Disjoint union of fixity maps.  Throws exception if not disjoint.@@ -141,14 +142,15 @@   return (fixs, pols)  fixitiesAndPolarities' :: MonadFixityError m => [Declaration] -> MonadicFixPol m-fixitiesAndPolarities' = foldMap $ \ d -> case d of+fixitiesAndPolarities' = foldMap $ \case   -- These declarations define polarities:   Pragma (PolarityPragma _ x occs) -> 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 xs $ \ x -> (x, Fixity' f noNotation $ getRange x)+  Infix  f xs     -> returnFix $ Map.fromList $ for (List1.toList xs) $ \ x -> (x, Fixity' f noNotation $ getRange x)   -- We look into these blocks:   Mutual    _ ds' -> fixitiesAndPolarities' ds'+  InterleavedMutual _ ds' -> fixitiesAndPolarities' ds'   Abstract  _ ds' -> fixitiesAndPolarities' ds'   Private _ _ ds' -> fixitiesAndPolarities' ds'   InstanceB _ ds' -> fixitiesAndPolarities' ds'@@ -156,27 +158,29 @@   -- All other declarations are ignored.   -- We expand these boring cases to trigger a revisit   -- in case the @Declaration@ type is extended in the future.-  TypeSig     {}  -> mempty-  FieldSig    {}  -> mempty-  Generalize  {}  -> mempty-  Field       {}  -> mempty-  FunClause   {}  -> mempty-  DataSig     {}  -> mempty-  DataDef     {}  -> mempty-  Data        {}  -> mempty-  RecordSig   {}  -> mempty-  RecordDef   {}  -> mempty-  Record      {}  -> mempty-  PatternSyn  {}  -> mempty-  Postulate   {}  -> mempty-  Primitive   {}  -> mempty-  Open        {}  -> mempty-  Import      {}  -> mempty-  ModuleMacro {}  -> mempty-  Module      {}  -> mempty-  UnquoteDecl {}  -> mempty-  UnquoteDef  {}  -> mempty-  Pragma      {}  -> mempty+  TypeSig         {}  -> mempty+  FieldSig        {}  -> mempty+  Generalize      {}  -> mempty+  Field           {}  -> mempty+  FunClause       {}  -> mempty+  DataSig         {}  -> mempty+  DataDef         {}  -> mempty+  Data            {}  -> mempty+  RecordSig       {}  -> mempty+  RecordDef       {}  -> mempty+  Record          {}  -> mempty+  RecordDirective {}  -> mempty+  LoneConstructor {}  -> mempty+  PatternSyn      {}  -> mempty+  Postulate       {}  -> mempty+  Primitive       {}  -> mempty+  Open            {}  -> mempty+  Import          {}  -> mempty+  ModuleMacro     {}  -> mempty+  Module          {}  -> mempty+  UnquoteDecl     {}  -> mempty+  UnquoteDef      {}  -> mempty+  Pragma          {}  -> mempty  data DeclaredNames = DeclaredNames { _allNames, _postulates, _privateNames :: Set Name } @@ -203,24 +207,27 @@ -- | Compute the names defined in a declaration. We stay in the current scope, --   i.e., do not go into modules. declaredNames :: Declaration -> DeclaredNames-declaredNames d = case d of+declaredNames = \case   TypeSig _ _ x _      -> declaresName x   FieldSig _ _ x _     -> declaresName x   Field _ fs           -> foldMap declaredNames fs-  FunClause (LHS p [] [] _) _ _ _-    | IdentP (QName x) <- removeSingletonRawAppP p+  FunClause (LHS p [] []) _ _ _+    | IdentP (QName x) <- removeParenP p                        -> declaresName x   FunClause{}          -> mempty   DataSig _ x _ _      -> declaresName x   DataDef _ _ _ cs     -> foldMap declaredNames cs   Data _ x _ _ cs      -> declaresName x <> foldMap declaredNames cs   RecordSig _ x _ _    -> declaresName x-  RecordDef _ x _ _ c _ _ -> declaresNames $     foldMap (:[]) (fst <$> c)-  Record _ x _ _ c _ _ _  -> declaresNames $ x : foldMap (:[]) (fst <$> c)+  RecordDef _ x d _ _  -> declaresNames $     foldMap (:[]) (fst <$> recConstructor d)+  Record _ x d _ _ _   -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d)+  RecordDirective _    -> mempty   Infix _ _            -> mempty   Syntax _ _           -> mempty   PatternSyn _ x _ _   -> declaresName x   Mutual    _ ds       -> foldMap declaredNames ds+  InterleavedMutual    _ ds -> foldMap declaredNames ds+  LoneConstructor _ ds -> foldMap declaredNames ds   Abstract  _ ds       -> foldMap declaredNames ds   Private _ _ ds       -> allPrivateNames $ foldMap declaredNames ds   InstanceB _ ds       -> foldMap declaredNames ds@@ -237,5 +244,5 @@   -- BUILTIN pragmas which do not require an accompanying definition declare   -- the (unqualified) name they mention.   Pragma (BuiltinPragma _ b (QName x))-    | rangedThing b `elem` builtinsNoDef -> declaresName x+    | isBuiltinNoDef $ rangedThing b -> declaresName x   Pragma{}             -> mempty

src/full/Agda/Syntax/Concrete/Generic.hs view

@@ -12,6 +12,8 @@ import Agda.Syntax.Concrete  import Agda.Utils.Either+import Agda.Utils.List1 (List1)+import Agda.Utils.List2 (List2)  import Agda.Utils.Impossible @@ -22,81 +24,69 @@   mapExpr :: (Expr -> Expr) -> a -> a   -- ^ This corresponds to 'map'. +  foldExpr :: Monoid m => (Expr -> m) -> a -> m+  -- ^ This corresponds to 'foldMap'.+   traverseExpr :: Monad m => (Expr -> m Expr) -> a -> m a   -- ^ This corresponds to 'mapM'. -  foldExpr :: Monoid m => (Expr -> m) -> a -> m-  -- ^ This is a reduce.+  default mapExpr :: (Functor t, ExprLike b, t b ~ a) => (Expr -> Expr) -> a -> a+  mapExpr = fmap . mapExpr -  traverseExpr = __IMPOSSIBLE__  -- TODO: implement!-  foldExpr     = __IMPOSSIBLE__  -- TODO: implement!+  default foldExpr+    :: (Monoid m, Foldable t, ExprLike b, t b ~ a)+    => (Expr -> m) -> a -> m+  foldExpr = foldMap . foldExpr +  default traverseExpr+    :: (Monad m, Traversable t, ExprLike b, t b ~ a)+    => (Expr -> m Expr) -> a -> m a+  traverseExpr = traverse . traverseExpr++ -- * Instances for things that do not contain expressions.  instance ExprLike () where-  mapExpr f = id+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return  instance ExprLike Name where-  mapExpr f = id+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return  instance ExprLike QName where-  mapExpr f = id+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return  instance ExprLike Bool where-  mapExpr f = id---- * Instances for functors.--instance ExprLike a => ExprLike (WithHiding a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr--instance ExprLike a => ExprLike (Named name a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return -instance ExprLike a => ExprLike (Arg a) where  -- TODO guilhem-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+-- * Instances for collections and decorations. -instance ExprLike a => ExprLike [a] where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+instance ExprLike a => ExprLike [a]+instance ExprLike a => ExprLike (List1 a)+instance ExprLike a => ExprLike (List2 a)+instance ExprLike a => ExprLike (Maybe a) -instance ExprLike a => ExprLike (Maybe a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+instance ExprLike a => ExprLike (Arg a)+instance ExprLike a => ExprLike (Named name a)+instance ExprLike a => ExprLike (WithHiding a) -instance ExprLike a => ExprLike (MaybePlaceholder a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+instance ExprLike a => ExprLike (MaybePlaceholder a)+instance ExprLike a => ExprLike (RHS' a)+instance ExprLike a => ExprLike (TypedBinding' a)+instance ExprLike a => ExprLike (WhereClause' a)  instance (ExprLike a, ExprLike b) => ExprLike (Either a b) where   mapExpr f      = bimap (mapExpr f) (mapExpr f)   traverseExpr f = traverseEither (traverseExpr f) (traverseExpr f)   foldExpr f     = either (foldExpr f) (foldExpr f) -instance ExprLike a => ExprLike (TypedBinding' a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr--instance ExprLike a => ExprLike (RHS' a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr--instance ExprLike a => ExprLike (WhereClause' a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr- instance (ExprLike a, ExprLike b) => ExprLike (a, b) where   mapExpr      f (x, y) = (mapExpr f x, mapExpr f y)   traverseExpr f (x, y) = (,) <$> traverseExpr f x <*> traverseExpr f y@@ -128,13 +118,9 @@      InstanceArg r e    -> f $ InstanceArg r          $ mapE e      Lam r bs e         -> f $ Lam r       (mapE bs)  $ mapE e      AbsurdLam{}        -> f $ e0-     ExtendedLam r cs   -> f $ ExtendedLam r          $ mapE cs+     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-     Set{}              -> f $ e0-     Prop{}             -> f $ e0-     SetN{}             -> f $ e0-     PropN{}            -> f $ e0      Rec r es           -> f $ Rec r                  $ mapE es      RecUpdate r e es   -> f $ RecUpdate r (mapE e)   $ mapE es      Let r ds e         -> f $ Let r       (mapE ds)  $ mapE e@@ -154,8 +140,13 @@      Equal{}            -> f $ e0      Ellipsis{}         -> f $ e0      Generalized e      -> f $ Generalized            $ mapE e-   where mapE e = mapExpr f e+   where+     mapE :: ExprLike e => e -> e+     mapE = mapExpr f +  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__+ instance ExprLike FieldAssignment where   mapExpr      f (FieldAssignment x e) = FieldAssignment x (mapExpr f e)   traverseExpr f (FieldAssignment x e) = (\e' -> FieldAssignment x e') <$> traverseExpr f e@@ -167,41 +158,61 @@   foldExpr     f (ModuleAssignment m es i) = foldExpr f es  instance ExprLike a => ExprLike (OpApp a) where-  mapExpr f e0 = case e0 of+  mapExpr f = \case      SyntaxBindingLambda r bs e -> SyntaxBindingLambda r (mapE bs) $ mapE e      Ordinary                 e -> Ordinary                        $ mapE e-   where mapE e = mapExpr f e+   where+     mapE :: ExprLike e => e -> e+     mapE = mapExpr f+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike LamBinding where-  mapExpr f e0 = case e0 of-     DomainFree{}  -> e0+  mapExpr f = \case+     e@DomainFree{}-> e      DomainFull bs -> DomainFull $ mapE bs    where mapE e = mapExpr f e+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike LHS where-  mapExpr f e0 = case e0 of-     LHS ps res wes ell -> LHS ps (mapE res) (mapE wes) ell-   where mapE e = mapExpr f e+  mapExpr f = \case+     LHS ps res wes -> LHS ps (mapE res) (mapE wes)+   where+     mapE :: ExprLike a => a -> a+     mapE = mapExpr f+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__ -instance (ExprLike qn, ExprLike e) => ExprLike (RewriteEqn' qn p e) where+instance (ExprLike qn, ExprLike e) => ExprLike (RewriteEqn' qn nm p e) where   mapExpr f = \case     Rewrite es    -> Rewrite (mapExpr f es)-    Invert qn pes -> Invert qn (map (mapExpr f <$>) pes)+    Invert qn pes -> Invert qn (fmap (fmap $ fmap $ mapExpr f) pes)+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike LamClause where-  mapExpr f (LamClause lhs rhs wh ca) =-    LamClause (mapExpr f lhs) (mapExpr f rhs) (mapExpr f wh) (mapExpr f ca)+  mapExpr f (LamClause ps rhs ca) = LamClause ps (mapExpr f rhs) ca+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike DoStmt where   mapExpr f (DoBind r p e cs) = DoBind r p (mapExpr f e) (mapExpr f cs)   mapExpr f (DoThen e)        = DoThen (mapExpr f e)   mapExpr f (DoLet r ds)      = DoLet r (mapExpr f ds) +  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__+ instance ExprLike ModuleApplication where-  mapExpr f e0 = case e0 of+  mapExpr f = \case      SectionApp r bs e -> SectionApp r (mapE bs) $ mapE e-     RecordModuleInstance{} -> e0-   where mapE e = mapExpr f e+     e@RecordModuleInstance{} -> e+   where+     mapE :: ExprLike e => e -> e+     mapE = mapExpr f+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike Declaration where   mapExpr f = \case@@ -213,12 +224,15 @@      DataDef r n bs cs         -> DataDef r n (mapE bs)                $ mapE cs      Data r n bs e cs          -> Data r n (mapE bs) (mapE e)          $ mapE cs      RecordSig r ind bs e      -> RecordSig r ind (mapE bs)            $ mapE e-     RecordDef r n ind eta c tel ds -> RecordDef r n ind eta c (mapE tel) $ mapE ds-     Record r n ind eta c tel e ds  -> Record r n ind eta c (mapE tel) (mapE e) $ mapE ds+     RecordDef r n dir tel ds  -> RecordDef r n dir (mapE tel)         $ mapE ds+     Record r n dir tel e ds   -> Record r n dir (mapE tel) (mapE e)   $ mapE ds+     e@RecordDirective{}       -> e      e@Infix{}                 -> e      e@Syntax{}                -> e      e@PatternSyn{}            -> e      Mutual    r ds            -> Mutual    r                          $ mapE ds+     InterleavedMutual r ds    -> InterleavedMutual r                  $ mapE ds+     LoneConstructor r ds      -> LoneConstructor r                    $ mapE ds      Abstract  r ds            -> Abstract  r                          $ mapE ds      Private   r o ds          -> Private   r o                        $ mapE ds      InstanceB r ds            -> InstanceB r                          $ mapE ds@@ -233,11 +247,20 @@      UnquoteDecl r x e         -> UnquoteDecl r x (mapE e)      UnquoteDef r x e          -> UnquoteDef r x (mapE e)      e@Pragma{}                -> e-   where mapE e = mapExpr f e+   where+     mapE :: ExprLike e => e -> e+     mapE = mapExpr f +  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__++ {- Template  instance ExprLike a where-  mapExpr f e0 = case e0 of-   where mapE e = mapExpr f e+  mapExpr f = \case+    where mapE e = mapExpr f e+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__+ -}

+ src/full/Agda/Syntax/Concrete/Glyph.hs view

@@ -0,0 +1,116 @@+{-| Choice of Unicode or ASCII glyphs.+-}+module Agda.Syntax.Concrete.Glyph+  ( UnicodeOrAscii(..)+  , unsafeSetUnicodeOrAscii+  , specialCharactersForGlyphs+  , braces', dbraces+  , forallQ+  , leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt+  , arrow, lambda+  , 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.List+import Agda.Utils.Null+import Agda.Utils.Pretty++-- | We want to know whether we are allowed to insert unicode characters or not.+data UnicodeOrAscii+  = UnicodeOk+  | AsciiOnly+  deriving (Show, Eq, Enum, Bounded, Generic)++instance NFData UnicodeOrAscii++{-# NOINLINE unsafeUnicodeOrAsciiIORef #-}+unsafeUnicodeOrAsciiIORef :: IORef UnicodeOrAscii+unsafeUnicodeOrAsciiIORef = UNSAFE.unsafePerformIO $ newIORef UnicodeOk++{-# NOINLINE unsafeSetUnicodeOrAscii #-}+unsafeSetUnicodeOrAscii :: UnicodeOrAscii -> IO ()+unsafeSetUnicodeOrAscii = writeIORef unsafeUnicodeOrAsciiIORef++-- | Are we allowed to use unicode supscript characters?+unsafeUnicodeOrAscii :: UnicodeOrAscii+unsafeUnicodeOrAscii = UNSAFE.unsafePerformIO (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+  , _leftIdiomBrkt  :: Doc+  , _rightIdiomBrkt :: Doc+  , _emptyIdiomBrkt :: Doc+  }++specialCharactersUnicode :: SpecialCharacters+specialCharactersUnicode = SpecialCharacters+  { _dbraces = (("\x2983 " <>) . (<> " \x2984"))+  , _lambda  = "\x03bb"+  , _arrow   = "\x2192"+  , _forallQ = "\x2200"+  , _leftIdiomBrkt  = "\x2987"+  , _rightIdiomBrkt = "\x2988"+  , _emptyIdiomBrkt = "\x2987\x2988"+  }++specialCharactersAscii :: SpecialCharacters+specialCharactersAscii = SpecialCharacters+  { _dbraces = braces . braces'+  , _lambda  = "\\"+  , _arrow   = "->"+  , _forallQ = "forall"+  , _leftIdiomBrkt  = "(|"+  , _rightIdiomBrkt = "|)"+  , _emptyIdiomBrkt = "(|)"+  }++-- | Return the glyph set based on a given (unicode or ascii) glyph mode+specialCharactersForGlyphs :: UnicodeOrAscii -> SpecialCharacters+specialCharactersForGlyphs UnicodeOk = specialCharactersUnicode+specialCharactersForGlyphs AsciiOnly = specialCharactersAscii++-- | Choose the glyph set based on the unsafe IORef.+{-# NOINLINE specialCharacters #-}+specialCharacters :: SpecialCharacters+specialCharacters = specialCharactersForGlyphs unsafeUnicodeOrAscii++braces' :: Doc -> Doc+braces' d = caseList (render d) (braces d) {-else-} $ \ c cs ->+  braces (spaceIfDash c <> d <> spaceIfDash (last1 c cs))+  -- Add space to avoid starting a comment (Ulf, 2010-09-13, #269)+  -- Andreas, 2018-07-21, #3161: Also avoid ending a comment+  where+  spaceIfDash '-' = " "+  spaceIfDash _   = empty++-- double braces...+dbraces :: Doc -> Doc+dbraces = _dbraces specialCharacters++-- forall quantifier+forallQ :: Doc+forallQ = _forallQ specialCharacters++-- left, right, and empty idiom bracket+leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt :: Doc+leftIdiomBrkt  = _leftIdiomBrkt  specialCharacters+rightIdiomBrkt = _rightIdiomBrkt specialCharacters+emptyIdiomBrkt = _emptyIdiomBrkt specialCharacters++arrow, lambda :: Doc+arrow  = _arrow specialCharacters+lambda = _lambda specialCharacters

src/full/Agda/Syntax/Concrete/Name.hs view

@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-} -- for type equality ~- {-| Names in the concrete syntax are just strings (or lists of strings for     qualified names). -}@@ -20,11 +16,16 @@ import System.FilePath  import Agda.Syntax.Common+import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Position  import Agda.Utils.FileName import Agda.Utils.Lens+import Agda.Utils.List  (last1)+import Agda.Utils.List1 (List1, pattern (:|), (<|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Pretty+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Suffix @@ -42,7 +43,7 @@   = Name -- ^ A (mixfix) identifier.     { nameRange     :: Range     , nameInScope   :: NameInScope-    , nameNameParts :: [NamePart]+    , nameNameParts :: NameParts     }   | NoName -- ^ @_@.     { nameRange     :: Range@@ -50,18 +51,20 @@     }   deriving Data +type NameParts = List1 NamePart+ -- | 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 n = case n of-  Name _ _ (x : xs@(_:_)) -> x == Hole || last xs == Hole-  _                       -> False+isOpenMixfix = \case+  Name _ _ (x :| x' : xs) -> x == Hole || last1 x' xs == Hole+  _ -> False  instance Underscore Name where   underscore = NoName noRange __IMPOSSIBLE__   isUnderscore NoName{} = True-  isUnderscore (Name {nameNameParts = [Id x]}) = isUnderscore x+  isUnderscore (Name {nameNameParts = Id x :| []}) = isUnderscore x   isUnderscore _ = False  -- | Mixfix identifiers are composed of words and holes,@@ -125,35 +128,59 @@  data TopLevelModuleName = TopLevelModuleName   { moduleNameRange :: Range-  , moduleNameParts :: [String]+  , moduleNameParts :: List1 String   }-  deriving (Show, Data)+  deriving (Show, Data, Generic)  instance Eq    TopLevelModuleName where (==)    = (==)    `on` moduleNameParts instance Ord   TopLevelModuleName where compare = compare `on` moduleNameParts instance Sized TopLevelModuleName where size    = size     .   moduleNameParts  ------------------------------------------------------------------------+-- * Constructing simple 'Name's.+------------------------------------------------------------------------++-- | Create an ordinary 'InScope' name.+simpleName :: RawName -> Name+simpleName = Name noRange InScope . singleton . Id++-- | Create a binary operator name in scope.+simpleBinaryOperator :: RawName -> Name+simpleBinaryOperator s = Name noRange InScope $ Hole :| Id s : Hole : []++-- | Create an ordinary 'InScope' name containing a single 'Hole'.+simpleHole :: Name+simpleHole = Name noRange InScope $ singleton Hole++------------------------------------------------------------------------ -- * Operations on 'Name' and 'NamePart' ------------------------------------------------------------------------ +-- | Don't use on 'NoName{}'.+lensNameParts :: Lens' NameParts Name+lensNameParts f = \case+  n@Name{} -> f (nameNameParts n) <&> \ ps -> n { nameNameParts = ps }+  NoName{} -> __IMPOSSIBLE__+ nameToRawName :: Name -> RawName nameToRawName = prettyShow -nameParts :: Name -> [NamePart]+nameParts :: Name -> NameParts nameParts (Name _ _ ps)    = ps-nameParts (NoName _ _)     = [Id "_"] -- To not return an empty list+nameParts (NoName _ _)     = singleton $ Id "_" -- To not return an empty list  nameStringParts :: Name -> [RawName]-nameStringParts n = [ s | Id s <- nameParts n ]+nameStringParts n = [ s | Id s <- List1.toList $ nameParts n ]  -- | Parse a string to parts of a concrete name. -- --   Note: @stringNameParts "_" == [Id "_"] == nameParts NoName{}@ -stringNameParts :: String -> [NamePart]-stringNameParts "_" = [Id "_"]   -- NoName-stringNameParts s = loop s where+stringNameParts :: String -> NameParts+stringNameParts ""  = singleton $ Id "_"  -- NoName+stringNameParts "_" = singleton $ Id "_"  -- NoName+stringNameParts s = List1.fromList $ loop s+  where   loop ""                              = []   loop ('_':s)                         = Hole : loop s   loop s | (x, s') <- break (== '_') s = Id (stringToRawName x) : loop s'@@ -162,8 +189,8 @@ class NumHoles a where   numHoles :: a -> Int -instance NumHoles [NamePart] where-  numHoles = length . filter (== Hole)+instance NumHoles NameParts where+  numHoles = length . List1.filter (== Hole)  instance NumHoles Name where   numHoles NoName{}         = 0@@ -174,20 +201,21 @@   numHoles (Qual _ x) = numHoles x  -- | Is the name an operator?-+--   Needs at least 2 'NamePart's. isOperator :: Name -> Bool-isOperator (NoName {})     = False-isOperator (Name _ _ ps)   = length ps > 1+isOperator = \case+  Name _ _ (_ :| _ : _) -> True+  _ -> False  isHole :: NamePart -> Bool isHole Hole = True isHole _    = False  isPrefix, isPostfix, isInfix, isNonfix :: Name -> Bool-isPrefix  x = not (isHole (head xs)) &&      isHole (last xs)  where xs = nameParts x-isPostfix x =      isHole (head xs)  && not (isHole (last xs)) where xs = nameParts x-isInfix   x =      isHole (head xs)  &&      isHole (last xs)  where xs = nameParts x-isNonfix  x = not (isHole (head xs)) && not (isHole (last xs)) where xs = nameParts x+isPrefix  x = not (isHole (List1.head xs)) &&      isHole (List1.last xs)  where xs = nameParts x+isPostfix x =      isHole (List1.head xs)  && not (isHole (List1.last xs)) where xs = nameParts x+isInfix   x =      isHole (List1.head xs)  &&      isHole (List1.last xs)  where xs = nameParts x+isNonfix  x = not (isHole (List1.head xs)) && not (isHole (List1.last xs)) where xs = nameParts x   ------------------------------------------------------------------------@@ -218,7 +246,7 @@ instance LensInScope Name where   lensInScope f = \case     n@Name{ nameInScope = nis } -> (\nis' -> n { nameInScope = nis' }) <$> f nis-    n@NoName{} -> const n <$> f InScope+    n@NoName{} -> n <$ f InScope  instance LensInScope QName where   lensInScope f = \case@@ -229,42 +257,83 @@ -- * Generating fresh names ------------------------------------------------------------------------ -nextStr :: String -> String-nextStr s = case suffixView s of-  (s0, suf) -> addSuffix s0 (nextSuffix suf)+-- | Method by which to generate fresh unshadowed names.+data FreshNameMode+  = UnicodeSubscript+  -- ^ Append an integer Unicode subscript: x, x₁, x₂, …+  | AsciiCounter+  -- ^ Append an integer ASCII counter: x, x1, x2, … +  -- Note that @Agda.Utils.Suffix@ supports an additional style, @Prime@, but+  -- we currently only encounter it when extending an existing name of that+  -- format, (x', x'', …), not for an initially-generated permutation. There's+  -- no reason we couldn't, except that we currently choose between+  -- subscript/counter styles based on the --no-unicode mode rather than any+  -- finer-grained option.+  --   | PrimeTickCount+  --   ^ Append an ASCII prime/apostrophe: x, x', x'', …++nextRawName :: FreshNameMode -> RawName -> RawName+nextRawName freshNameMode s = addSuffix root (maybe initialSuffix nextSuffix suffix)+  where+  (root, suffix) = suffixView s+  initialSuffix = case freshNameMode of+    UnicodeSubscript -> Subscript 1+    AsciiCounter -> Index 1+ -- | Get the next version of the concrete name. For instance, --   @nextName "x" = "x₁"@.  The name must not be a 'NoName'.-nextName :: Name -> Name-nextName NoName{} = __IMPOSSIBLE__-nextName x@Name{ nameNameParts = ps } = x { nameInScope = NotInScope, nameNameParts = nextSuf ps }+nextName :: FreshNameMode -> Name -> Name+nextName freshNameMode x@Name{} = setNotInScope $ over (lensNameParts . lastIdPart) (nextRawName freshNameMode) x+nextName             _ NoName{} = __IMPOSSIBLE__++-- | Zoom on the last non-hole in a name.+lastIdPart :: Lens' RawName NameParts+lastIdPart f = loop   where-    nextSuf [Id s]       = [Id $ nextStr s]-    nextSuf [Id s, Hole] = [Id $ nextStr s, Hole]-    nextSuf (p : ps)     = p : nextSuf ps-    nextSuf []           = __IMPOSSIBLE__+  loop = \case+    Id s :| []     -> f s <&> \ s -> Id s :| []+    Id s :| [Hole] -> f s <&> \ s -> Id s :| [Hole]+    p1 :| p2 : ps  -> (p1 <|) <$> loop (p2 :| ps)+    Hole :| []     -> __IMPOSSIBLE__  -- | Get the first version of the concrete name that does not satisfy --   the given predicate.-firstNonTakenName :: (Name -> Bool) -> Name -> Name-firstNonTakenName taken x =+firstNonTakenName :: FreshNameMode -> (Name -> Bool) -> Name -> Name+firstNonTakenName freshNameMode taken x =   if taken x-  then firstNonTakenName taken (nextName x)+  then firstNonTakenName freshNameMode taken (nextName freshNameMode x)   else x +-- | Lens for accessing and modifying the suffix of a name.+--   The suffix of a @NoName@ is always @Nothing@, and should not be+--   changed.+nameSuffix :: Lens' (Maybe Suffix) Name+nameSuffix (f :: Maybe Suffix -> f (Maybe Suffix)) = \case++  n@NoName{} -> f Nothing <&> \case+    Nothing -> n+    Just {} -> __IMPOSSIBLE__++  n@Name{} -> lensNameParts (lastIdPart idSuf) n+    where+    idSuf s =+      let (root, suffix) = suffixView s+      in maybe root (addSuffix root) <$> (f suffix)++-- | Split a name into a base name plus a suffix.+nameSuffixView :: Name -> (Maybe Suffix, Name)+nameSuffixView = nameSuffix (,Nothing)++-- | Replaces the suffix of a name. Unless the suffix is @Nothing@,+--   the name should not be @NoName@.+setNameSuffix :: Maybe Suffix -> Name -> Name+setNameSuffix = set nameSuffix+ -- | Get a raw version of the name with all suffixes removed. For---   instance, @nameRoot "x₁₂₃" = "x"@. The name must not be a---   'NoName'.+--   instance, @nameRoot "x₁₂₃" = "x"@. nameRoot :: Name -> RawName-nameRoot NoName{} = __IMPOSSIBLE__-nameRoot x@Name{ nameNameParts = ps } =-    nameToRawName $ x{ nameNameParts = root ps }-  where-    root [Id s] = [Id $ strRoot s]-    root [Id s, Hole] = [Id $ strRoot s , Hole]-    root (p : ps) = p : root ps-    root [] = __IMPOSSIBLE__-    strRoot = fst . suffixView+nameRoot x = nameToRawName $ snd $ nameSuffixView x  sameRoot :: Name -> Name -> Bool sameRoot = (==) `on` nameRoot@@ -273,6 +342,11 @@ -- * Operations on qualified names ------------------------------------------------------------------------ +-- | Lens for the unqualified part of a QName+lensQNameName :: Lens' Name QName+lensQNameName f (QName n)  = QName <$> f n+lensQNameName f (Qual m n) = Qual m <$> lensQNameName f n+ -- | @qualify A.B x == A.B.x@ qualify :: QName -> Name -> QName qualify (QName m) x     = Qual m (QName x)@@ -288,9 +362,9 @@   unqualify' (Qual _ x) = unqualify' x  -- | @qnameParts A.B.x = [A, B, x]@-qnameParts :: QName -> [Name]-qnameParts (Qual x q) = x : qnameParts q-qnameParts (QName x)  = [x]+qnameParts :: QName -> List1 Name+qnameParts (Qual x q) = x <| qnameParts q+qnameParts (QName x)  = singleton x  -- | Is the name (un)qualified? @@ -310,27 +384,15 @@ -- name is assumed to represent a top-level module name.  toTopLevelModuleName :: QName -> TopLevelModuleName-toTopLevelModuleName q = TopLevelModuleName (getRange q) $ map prettyShow $ qnameParts q---- UNUSED--- -- | Turns a top level module into a qualified name with 'noRange'.---- fromTopLevelModuleName :: TopLevelModuleName -> QName--- fromTopLevelModuleName (TopLevelModuleName _ [])     = __IMPOSSIBLE__--- fromTopLevelModuleName (TopLevelModuleName _ (x:xs)) = loop x xs---   where---   loop x []       = QName (mk x)---   loop x (y : ys) = Qual  (mk x) $ loop y ys---   mk :: String -> Name---   mk x = Name noRange [Id x]+toTopLevelModuleName q = TopLevelModuleName (getRange q) $+  fmap nameToRawName $ qnameParts q  -- | Turns a top-level module name into a file name with the given -- suffix.  moduleNameToFileName :: TopLevelModuleName -> String -> FilePath-moduleNameToFileName (TopLevelModuleName _ []) ext = __IMPOSSIBLE__ moduleNameToFileName (TopLevelModuleName _ ms) ext =-  joinPath (init ms) </> last ms <.> ext+  joinPath (List1.init ms) </> List1.last ms <.> ext  -- | Finds the current project's \"root\" directory, given a project -- file and the corresponding top-level module name.@@ -343,9 +405,7 @@ projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath projectRoot file (TopLevelModuleName _ m) =   mkAbsolute $-  foldr (.) id (replicate (length m - 1) takeDirectory) $-  takeDirectory $-  filePath file+    iterate takeDirectory (filePath file) !! length m  ------------------------------------------------------------------------ -- * No name stuff@@ -356,7 +416,7 @@ noName_ = noName noRange  noName :: Range -> Name-noName r = NoName r (NameId 0 0)+noName r = NoName r (NameId 0 noModuleNameHash)  -- | Check whether a name is the empty name "_". class IsNoName a where@@ -372,11 +432,11 @@   isNoName = isUnderscore  instance IsNoName Name where-  isNoName (NoName _ _)      = True-  isNoName (Name _ _ [Hole]) = True   -- TODO: Track down where these come from-  isNoName (Name _ _ [])     = True-  isNoName (Name _ _ [Id x]) = isNoName x-  isNoName _                 = False+  isNoName = \case+    NoName{}              -> True+    Name _ _ (Hole :| []) -> True+    Name _ _ (Id x :| []) -> isNoName x+    _ -> False  instance IsNoName QName where   isNoName (QName x) = isNoName x@@ -391,29 +451,16 @@ -- * Showing names ------------------------------------------------------------------------ --- deriving instance Show Name--- deriving instance Show NamePart--- deriving instance Show QName---- TODO: 'Show' should output Haskell-parseable representations.--- The following instances are deprecated, and Pretty should be used--- instead.  Later, simply derive Show for these types:--instance Show Name where-  show = prettyShow--instance Show NamePart where-  show = prettyShow--instance Show QName where-  show = prettyShow+deriving instance Show Name+deriving instance Show NamePart+deriving instance Show QName  ------------------------------------------------------------------------ -- * Printing names ------------------------------------------------------------------------  instance Pretty Name where-  pretty (Name _ _ xs)    = hcat $ map pretty xs+  pretty (Name _ _ xs)    = hcat $ fmap pretty xs   pretty (NoName _ _)     = "_"  instance Pretty NamePart where@@ -427,15 +474,15 @@   pretty (QName x)  = pretty x  instance Pretty TopLevelModuleName where-  pretty (TopLevelModuleName _ ms) = text $ List.intercalate "." ms+  pretty (TopLevelModuleName _ ms) = text $ List.intercalate "." $ List1.toList ms  ------------------------------------------------------------------------ -- * Range instances ------------------------------------------------------------------------  instance HasRange Name where-    getRange (Name r _ ps)    = r-    getRange (NoName r _)     = r+    getRange (Name r _ _ps) = r+    getRange (NoName r _)   = r  instance HasRange QName where     getRange (QName  x) = getRange x@@ -470,12 +517,12 @@ -- * NFData instances ------------------------------------------------------------------------ --- | Ranges are not forced.- instance NFData NameInScope where   rnf InScope    = ()   rnf NotInScope = () +-- | Ranges are not forced.+ instance NFData Name where   rnf (Name _ nis ns) = rnf nis `seq` rnf ns   rnf (NoName _ n)  = rnf n@@ -487,3 +534,5 @@ instance NFData QName where   rnf (Qual a b) = rnf a `seq` rnf b   rnf (QName a)  = rnf a++instance NFData TopLevelModuleName

src/full/Agda/Syntax/Concrete/Operators.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}  {-| The parser doesn't know about operators and parses everything as normal     function application. This module contains the functions that parses the@@ -19,7 +20,7 @@  import Control.Applicative ( Alternative((<|>))) import Control.Arrow (second)-import Control.Monad+import Control.Monad.Except (throwError)  import Data.Either (partitionEithers) import qualified Data.Foldable as Fold@@ -30,7 +31,6 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Traversable (traverse) import qualified Data.Traversable as Trav  import Agda.Syntax.Common@@ -40,7 +40,6 @@ import Agda.Syntax.Concrete.Pattern import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Position-import Agda.Syntax.Fixity import Agda.Syntax.Notation import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad@@ -53,6 +52,12 @@ import Agda.Utils.Either import Agda.Utils.Pretty 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.List2 as List2+import Agda.Utils.Maybe+import Agda.Utils.Monad (guardWithError) import Agda.Utils.Trie (Trie) import qualified Agda.Utils.Trie as Trie @@ -101,20 +106,19 @@   locals <- nubOn fst . notShadowedLocals <$> getLocalVars   -- Note: Debug printout aligned with the one in buildParsers.   reportS "scope.operators" 50-    [ "flat  = " ++ show flat-    , "defs  = " ++ show defs-    , "locals= " ++ show locals+    [ "flat  = " ++ prettyShow flat+    , "defs  = " ++ prettyShow defs+    , "locals= " ++ prettyShow locals     ]   let localNots  = map localOp locals-      localNames = Set.fromList $ map notaName localNots-      otherNots  = filter (\n -> not (Set.member (notaName n) localNames))-                          (concat defs)+      notLocal   = not . hasElem (map notaName localNots) . notaName+      otherNots  = concatMap (filter notLocal) defs   return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots   where     localOp (x, y) = namesToNotation (QName x) y-    split ops      = partitionEithers $ concatMap opOrNot ops+    split          = partitionEithers . concatMap opOrNot     opOrNot n      = Left (notaName n) :-                     if null (notation n) then [] else [Right n]+                     [Right n | not (null (notation n))]  -- | A data structure used internally by 'buildParsers'. data InternalParsers e = InternalParsers@@ -183,7 +187,7 @@         namesInExpr :: Set QName         namesInExpr = Set.fromList exprNames -        partListsInExpr' = map (nameParts . unqualify) $+        partListsInExpr' = map (List1.toList . nameParts . unqualify) $                            Set.toList namesInExpr          partListTrie f =@@ -235,7 +239,7 @@             IdPart p : _                -> rangedThing p             _                           -> __IMPOSSIBLE__ -        -- | Are the initial and final identifier parts present with+        -- Are the initial and final identifier parts present with         -- the right mix of leading and trailing underscores?         correctUnderscores :: Bool -> Bool -> Notation -> Bool         correctUnderscores withInitialHole withFinalHole n =@@ -274,7 +278,7 @@         (non, fix) = List.partition nonfix (filter (and . partsPresent) ops)          cons       = getDefinedNames-                       (someKindsOfNames [ConName, FldName, PatternSynName]) flat+                       (someKindsOfNames [ConName, CoConName, FldName, PatternSynName]) flat         conNames   = Set.fromList $                        filter (flip Set.member namesInExpr) $                        map (notaName . head) cons@@ -339,7 +343,7 @@         -- level comes first.         relatedOperators :: [(PrecedenceLevel, [NotationSection])]         relatedOperators =-          map (\((l, ns) : rest) -> (l, ns ++ concat (map snd rest))) .+          map (\((l, ns) : rest) -> (l, ns ++ concatMap snd rest)) .           List.groupBy ((==) `on` fst) .           List.sortBy (compare `on` fst) .           mapMaybe (\n -> case level n of@@ -356,29 +360,27 @@           nonWithSections      reportS "scope.operators" 50-      [ "unrelatedOperators = " ++ show unrelatedOperators-      , "nonWithSections    = " ++ show nonWithSections-      , "relatedOperators   = " ++ show relatedOperators+      [ "unrelatedOperators = " ++ prettyShow unrelatedOperators+      , "nonWithSections    = " ++ prettyShow nonWithSections+      , "relatedOperators   = " ++ prettyShow relatedOperators       ]      let g = Data.Function.fix $ \p -> InternalParsers               { pTop    = memoise TopK $                           Fold.asum $-                            foldr ($) (pApp p)-                              (map (\(l, ns) higher ->+                            foldr (\(l, ns) higher ->                                        mkP (Right l) parseSections-                                           (pTop p) ns higher True)-                                   relatedOperators) :-                            map (\(k, n) ->+                                           (pTop p) ns higher True) (pApp p)+                                   relatedOperators :+                            zipWith (\ k n ->                                     mkP (Left k) parseSections-                                        (pTop p) [n] (pApp p) False)-                                (zip [0..] unrelatedOperators)+                                        (pTop p) [n] (pApp p) False) [0..] unrelatedOperators               , pApp    = memoise AppK $ appP (pNonfix p) (pArgs p)               , pArgs   = argsP (pNonfix p)               , pNonfix = memoise NonfixK $                           Fold.asum $                             pAtom p :-                            flip map nonWithSections (\sect ->+                            map (\sect ->                               let n = sectNotation sect                                    inner :: forall k. NK k ->@@ -396,10 +398,12 @@                                   flip ($) <$> placeholder Beginning                                            <*> inner Post                                 NonfixNotation -> inner Non-                                NoNotation     -> __IMPOSSIBLE__)+                                NoNotation     -> __IMPOSSIBLE__) nonWithSections               , pAtom   = atomP isAtom               } +    -- Andreas, 2020-06-03 #4712+    -- Note: needs Agda to be compiled with DEBUG to print the grammar.     reportSDoc "scope.grammar" 10 $ return $       "Operator grammar:" $$ nest 2 (grammar (pTop g)) @@ -429,16 +433,13 @@              &&           fixityAssoc (notaFixity (sectNotation s)) == ass -        mkP :: PrecedenceKey-               -- ^ Memoisation key.+        mkP :: PrecedenceKey  -- Memoisation key.             -> ParseSections             -> Parser e e             -> [NotationSection]-            -> Parser e e-               -- ^ A parser for an expression of higher precedence.-            -> Bool-               -- ^ Include the \"expression of higher precedence\"-               -- parser as one of the choices?+            -> Parser e e  -- A parser for an expression of higher precedence.+            -> Bool  -- Include the \"expression of higher precedence\"+                     -- parser as one of the choices?             -> Parser e e         mkP key parseSections p0 ops higher includeHigher =             memoise (NodeK key) $@@ -524,11 +525,14 @@ ---------------------------------------------------------------------------  -- | Returns the list of possible parses.-parsePat :: ([Pattern] -> [Pattern]) -> Pattern -> [Pattern]+parsePat+  :: ([Pattern] -> [Pattern]) -- ^ Turns a 'RawAppP' into possible parses.+  -> Pattern                  -- ^ Pattern possibly containing 'RawAppP's.+  -> [Pattern]                -- ^ Possible parses, not containing 'RawAppP's. parsePat prs = \case     AppP p (Arg info q) ->         fullParen' <$> (AppP <$> parsePat prs p <*> (Arg info <$> traverse (parsePat prs) q))-    RawAppP _ ps     -> fullParen' <$> (parsePat prs =<< prs ps)+    RawAppP _ ps     -> fullParen' <$> (parsePat prs =<< prs (List2.toList ps))     OpAppP r d ns ps -> fullParen' . OpAppP r d ns <$> (mapM . traverse . traverse) (parsePat prs) ps     HiddenP _ _      -> fail "bad hidden argument"     InstanceP _ _    -> fail "bad instance argument"@@ -542,7 +546,8 @@     p@IdentP{}       -> return p     RecP r fs        -> RecP r <$> mapM (traverse (parsePat prs)) fs     p@EqualP{}       -> return p -- Andrea: cargo culted from DotP-    EllipsisP _      -> fail "bad ellipsis"+    EllipsisP r mp   -> caseMaybe mp (fail "bad ellipsis") $ \p ->+                          EllipsisP r . Just <$> parsePat prs p     WithP r p        -> WithP r <$> parsePat prs p  @@ -582,9 +587,16 @@    - the applied patterns -} --- | The result of 'parseLHS' is either a pattern ('Left') or a lhs ('Right').-type ParseLHS = Either Pattern (QName, LHSCore)+-- | The result of 'parseLHS'.+data ParseLHS+  = ParsePattern Pattern    -- ^ We parsed a pattern.+  | ParseLHS QName LHSCore  -- ^ We parsed a lhs. +instance Pretty ParseLHS where+  pretty = \case+    ParsePattern p  -> pretty p+    ParseLHS _f lhs -> pretty lhs+ -- | Parses a left-hand side, workhorse for 'parseLHS'. -- parseLHS'@@ -600,8 +612,8 @@        -- ^ The returned list contains all operators/notations/sections that        -- were used to generate the grammar. -parseLHS' IsLHS (Just qn) (RawAppP _ [WildP{}]) =-    return (Right (qn, LHSHead qn []), [])+parseLHS' IsLHS (Just qn) WildP{} =+    return (ParseLHS qn $ LHSHead qn [], [])  parseLHS' lhsOrPatSyn top p = do @@ -613,18 +625,22 @@                in  foldr seq () result `seq` result      -- Classify parse results.-    let cons = getNames (someKindsOfNames [ConName, PatternSynName])+    let cons = getNames (someKindsOfNames [ConName, CoConName, PatternSynName])                         (flattenedScope patP)     let flds = getNames (someKindsOfNames [FldName])                         (flattenedScope patP)-    let conf = PatternCheckConfig top cons flds-    case mapMaybe (validPattern conf) ps of+    let conf = PatternCheckConfig top (hasElem cons) (hasElem flds)++    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)] -> do reportS "scope.operators" 50 $ "Parsed lhs:" <+> pretty lhs                         return (lhs, operators patP)         -- No result.         []        -> typeError $ OperatorInformation (operators patP)-                               $ NoParseForLHS lhsOrPatSyn p+                               $ NoParseForLHS lhsOrPatSyn (catMaybes errs) p         -- Ambiguous result.         rs        -> typeError $ OperatorInformation (operators patP)                                $ AmbiguousParseForLHS lhsOrPatSyn p $@@ -634,64 +650,91 @@           map (notaName . head) $ getDefinedNames kinds flat          -- The pattern is retained for error reporting in case of ambiguous parses.-        validPattern :: PatternCheckConfig -> Pattern -> Maybe (Pattern, ParseLHS)-        validPattern conf p =-          case (classifyPattern conf p, top) of-            (Just res@Left{}, Nothing) -> Just (p, res)  -- expect pattern-            (Just res@Right{}, Just{}) -> Just (p, res)  -- expect lhs-            _ -> Nothing+        validPattern :: PatternCheckConfig -> Pattern -> PM (Pattern, ParseLHS)+        validPattern conf p = do+          res <- classifyPattern conf p+          case (res, top) of+            (ParsePattern{}, Nothing) -> return (p, res)  -- expect pattern+            (ParseLHS{}    , Just{} ) -> return (p, res)  -- expect lhs+            _ -> throwError Nothing  -- | Name sets for classifying a pattern. data PatternCheckConfig = PatternCheckConfig-  { topName  :: Maybe QName -- ^ Name of defined symbol.-  , conNames :: [QName]     -- ^ Valid constructor names.-  , fldNames :: [QName]     -- ^ Valid field names.+  { topName :: Maybe QName    -- ^ Name of defined symbol.+  , conName :: QName -> Bool  -- ^ Valid constructor name?+  , fldName :: QName -> Bool  -- ^ Valid field name?   } +-- | The monad for pattern checking and classification.+--+--   The error message is either empty or a subpattern that was found to be invalid.+type PM = Either (Maybe Pattern)+ -- | Returns zero or one classified patterns.-classifyPattern :: PatternCheckConfig -> Pattern -> Maybe ParseLHS+--   In case of zero, return the offending subpattern.+classifyPattern :: PatternCheckConfig -> Pattern -> PM ParseLHS classifyPattern conf p =   case patternAppView p of      -- case @f ps@-    Arg _ (Named _ (IdentP x)) : ps | Just x == topName conf -> do-      guard $ all validPat ps-      return $ Right (x, lhsCoreAddSpine (LHSHead x []) ps)+    Arg _ (Named _ (IdentP x)) :| ps | Just x == topName conf -> do+      mapM_ (valid . namedArg) ps+      return $ ParseLHS x $ lhsCoreAddSpine (LHSHead x []) ps      -- case @d ps@-    Arg _ (Named _ (IdentP x)) : ps | x `elem` fldNames conf -> do-      -- ps0 :: [NamedArg ParseLHS]-      ps0 <- mapM classPat ps-      let (ps1, rest) = span (isLeft . namedArg) ps0-      (p2, ps3) <- uncons rest -- when (null rest): no field pattern or def pattern found-      guard $ all (isLeft . namedArg) ps3-      let (f, lhs)      = fromR p2+    Arg _ (Named _ (IdentP x)) :| ps | fldName conf x -> do++      -- Step 1: check for valid copattern lhs.+      ps0 :: [NamedArg ParseLHS] <- mapM classPat ps+      let (ps1, rest) = span (isParsePattern . namedArg) ps0+      (p2, ps3) <- maybeToEither Nothing $ uncons rest+          -- when (null rest): no field pattern or def pattern found++      -- Ensure that the @ps3@ are patterns rather than lhss.+      mapM_ (guardWithError Nothing . isParsePattern . namedArg) ps3++      -- Step 2: construct the lhs.+      let (f, lhs0)     = fromParseLHS $ namedArg p2+          lhs           = setNamedArg p2 lhs0           (ps', _:ps'') = splitAt (length ps1) ps-      return $ Right (f, lhsCoreAddSpine (LHSProj x ps' lhs []) ps'')+      return $ ParseLHS f $ lhsCoreAddSpine (LHSProj x ps' lhs []) ps'' +    -- case @...@+    Arg _ (Named _ (EllipsisP r (Just p))) :| ps -> do+      classifyPattern conf p >>= \case  -- TODO: avoid re-parsing+        ParsePattern{}    -> throwError Nothing+        (ParseLHS f core) -> do+          mapM_ (valid . namedArg) ps+          let ellcore = LHSEllipsis r core+          return $ ParseLHS f $ lhsCoreAddSpine ellcore ps+     -- case: ordinary pattern-    _ -> do-      guard $ validConPattern (conNames conf) p-      return $ Left p+    _ -> ParsePattern p <$ valid p -  where -- allNames = conNames conf ++ fldNames conf-        validPat = validConPattern (conNames conf) . namedArg-        classPat :: NamedArg Pattern -> Maybe (NamedArg ParseLHS)-        classPat = Trav.mapM (Trav.mapM (classifyPattern conf))-        fromR :: NamedArg (Either a (b, c)) -> (b, NamedArg c)-        fromR (Arg info (Named n (Right (b, c)))) = (b, Arg info (Named n c))-        fromR (Arg info (Named n (Left  a     ))) = __IMPOSSIBLE__+  where+  valid = validConPattern $ conName conf +  classPat :: NamedArg Pattern -> PM (NamedArg ParseLHS)+  classPat = Trav.mapM (Trav.mapM (classifyPattern conf)) +  isParsePattern = \case+    ParsePattern{} -> True+    ParseLHS{}     -> False +  fromParseLHS :: ParseLHS -> (QName, LHSCore)+  fromParseLHS = \case+    ParseLHS f lhs -> (f, lhs)+    ParsePattern{} -> __IMPOSSIBLE__++ -- | Parses a left-hand side, and makes sure that it defined the expected name. parseLHS :: QName -> Pattern -> ScopeM LHSCore parseLHS top p = billToParser IsPattern $ do   (res, ops) <- parseLHS' IsLHS (Just top) p   case res of-    Right (f, lhs) -> return lhs+    ParseLHS f lhs -> return lhs     _ -> typeError $ OperatorInformation ops-                   $ NoParseForLHS IsLHS p+                   $ NoParseForLHS IsLHS [] p  -- | Parses a pattern. parsePattern :: Pattern -> ScopeM Pattern@@ -704,69 +747,95 @@ parsePatternOrSyn lhsOrPatSyn p = billToParser IsPattern $ do   (res, ops) <- parseLHS' lhsOrPatSyn Nothing p   case res of-    Left p -> return p-    _      -> typeError $ OperatorInformation ops-                        $ NoParseForLHS lhsOrPatSyn p+    ParsePattern p -> return p+    _ -> typeError $ OperatorInformation ops+                   $ NoParseForLHS lhsOrPatSyn [] p  -- | Helper function for 'parseLHS' and 'parsePattern'.-validConPattern :: [QName] -> Pattern -> Bool-validConPattern cons p = case appView p of-    [WithP _ p]   -> validConPattern cons p-    [_]           -> True-    IdentP x : ps -> elem x cons && all (validConPattern cons) ps-    [QuoteP _, _] -> True-    DotP _ e : ps -> all (validConPattern cons) ps-    _             -> False--- Andreas, 2012-06-04: I do not know why the following line was--- the catch-all case.  It seems that the new catch-all works also--- and is more logical.---    ps            -> all (validConPattern cons) ps+--+--   Returns a subpattern that is not a valid constructor pattern+--   or nothing if the whole pattern is a valid constructor pattern.+validConPattern+  :: (QName -> Bool)     -- ^ Test for constructor name.+  -> Pattern             -- ^ Supposedly a constructor pattern.+  -> PM ()   -- ^ Offending subpattern or nothing.+validConPattern cons = loop+  where+  loop p = case appView p of+      WithP _ p :| [] -> loop p+      _ :| []         -> ok+      IdentP x :| ps+        | cons x      -> mapM_ loop ps+        | otherwise   -> failure+      QuoteP _ :| [_] -> ok+      DotP _ e :| ps  -> mapM_ loop ps+      _               -> failure+    where+    ok      = return ()+    failure = throwError $ Just p + -- | Helper function for 'parseLHS' and 'parsePattern'.-appView :: Pattern -> [Pattern]-appView p = case p of-    AppP p a         -> appView p ++ [namedArg a]-    OpAppP _ op _ ps -> IdentP op : map namedArg ps-    ParenP _ p       -> appView p+appView :: Pattern -> List1 Pattern+appView = loop []+  where+  loop acc = \case+    AppP p a         -> loop (namedArg a : acc) p+    OpAppP _ op _ ps -> (IdentP op :| fmap namedArg ps)+                          `List1.append`+                        reverse acc+    ParenP _ p       -> loop acc p     RawAppP _ _      -> __IMPOSSIBLE__     HiddenP _ _      -> __IMPOSSIBLE__     InstanceP _ _    -> __IMPOSSIBLE__-    _                -> [p]+    p@IdentP{}       -> ret p+    p@WildP{}        -> ret p+    p@AsP{}          -> ret p+    p@AbsurdP{}      -> ret p+    p@LitP{}         -> ret p+    p@QuoteP{}       -> ret p+    p@DotP{}         -> ret p+    p@RecP{}         -> ret p+    p@EqualP{}       -> ret p+    p@EllipsisP{}    -> ret p+    p@WithP{}        -> ret p+   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 (init . qnameParts) qs+  nubOn id $ filter (not . null) $ map (List1.init . qnameParts) qs --- | Parse a list of expressions into an application.-parseApplication :: [Expr] -> ScopeM Expr-parseApplication [e] = return e+-- | 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 [ q | Ident q <- es ]+    p <- buildParsers IsExpr [ q | Ident q <- es0 ]      -- Parse-    let result = parser p es+    let result = parser p es0     case foldr seq () result `seq` result of-        [e] -> do+      [e]   -> do           reportSDoc "scope.operators" 50 $ return $             "Parsed an operator application:" <+> pretty e           return e-        []  -> typeError $ OperatorInformation (operators p)+      []    -> typeError $ OperatorInformation (operators p)                          $ NoParseForApplication es-        es' -> typeError $ OperatorInformation (operators p)+      e:es' -> typeError $ OperatorInformation (operators p)                          $ AmbiguousParseForApplication es-                         $ map fullParen es'+                         $ fmap fullParen (e :| es')  parseModuleIdentifier :: Expr -> ScopeM QName parseModuleIdentifier (Ident m) = return m parseModuleIdentifier e = typeError $ NotAModuleExpr e -parseRawModuleApplication :: [Expr] -> ScopeM (QName, [NamedArg Expr])-parseRawModuleApplication es = billToParser IsExpr $ do-    let e : es_args = es+parseRawModuleApplication :: List2 Expr -> ScopeM (QName, [NamedArg Expr])+parseRawModuleApplication es@(List2 e e2 rest) = billToParser IsExpr $ do+    let es_args = e2:rest     m <- parseModuleIdentifier e      -- Build the arguments parser@@ -778,11 +847,11 @@         [as] -> return (m, as)         []   -> typeError $ OperatorInformation (operators p)                           $ NoParseForApplication es-        ass -> do+        as : ass -> do           let f = fullParen . foldl (App noRange) (Ident m)           typeError $ OperatorInformation (operators p)                     $ AmbiguousParseForApplication es-                    $ map f ass+                    $ fmap f (as :| ass)  -- | Parse an expression into a module application --   (an identifier plus a list of arguments).@@ -818,7 +887,7 @@                 Hidden     -> e2                 Instance{} -> e2                 NotHidden  -> fullParen' <$> e2-    OpAppV x ns es -> par $ unExprView $ OpAppV x ns $ (map . fmap . fmap . fmap . fmap) fullParen' es+    OpAppV x ns es -> par $ unExprView $ OpAppV x ns $ (fmap . fmap . fmap . fmap . fmap) fullParen' es     LamV bs e -> par $ unExprView $ LamV bs (fullParen e)     where         par = unExprView . ParenV

src/full/Agda/Syntax/Concrete/Operators/Parser.hs view

@@ -1,10 +1,10 @@ {-# LANGUAGE GADTs        #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds    #-}  module Agda.Syntax.Concrete.Operators.Parser where  import Control.Applicative ( Alternative((<|>), many) )+import Control.Monad ((<=<))  import Data.Either import Data.Kind ( Type )@@ -15,22 +15,23 @@ import Agda.Syntax.Position import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common-import Agda.Syntax.Fixity import Agda.Syntax.Notation import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse) import qualified Agda.Syntax.Concrete.Operators.Parser.Monad as P  import Agda.Utils.Pretty-import Agda.Utils.List ( spanEnd )+import Agda.Utils.List  ( spanEnd )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Singleton  import Agda.Utils.Impossible  placeholder :: PositionInName -> Parser e (MaybePlaceholder e) placeholder p =   doc (text ("_" ++ show p)) $-  sat $ \t ->-  case t of+  sat $ \case     Placeholder p' | p' == p -> True     _                        -> False @@ -43,8 +44,7 @@   p' = noPlaceholder <$> p  satNoPlaceholder :: (e -> Maybe a) -> Parser e a-satNoPlaceholder p = sat' $ \tok ->-  case tok of+satNoPlaceholder p = sat' $ \case     NoPlaceholder _ e -> p e     Placeholder _     -> Nothing @@ -53,12 +53,12 @@     | WildV e     | OtherV e     | AppV e (NamedArg e)-    | OpAppV QName (Set A.Name) [NamedArg (MaybePlaceholder (OpApp e))]+    | OpAppV QName (Set A.Name) (OpAppArgs' e)       -- ^ The 'QName' is possibly ambiguous, but it must correspond       -- to one of the names in the set.     | HiddenArgV (Named_ e)     | InstanceArgV (Named_ e)-    | LamV [LamBinding] e+    | LamV (List1 LamBinding) e     | ParenV e --    deriving (Show) @@ -71,7 +71,7 @@   getRange = getRange . unExprView  instance IsExpr Expr where-    exprView e = case e of+    exprView = \case         Ident x         -> LocalV x         App _ e1 e2     -> AppV e1 e2         OpApp r d ns es -> OpAppV d ns es@@ -79,9 +79,9 @@         InstanceArg _ e -> InstanceArgV e         Paren _ e       -> ParenV e         Lam _ bs    e   -> LamV bs e-        Underscore{}    -> WildV e-        _               -> OtherV e-    unExprView e = case e of+        e@Underscore{}  -> WildV e+        e               -> OtherV e+    unExprView = \case         LocalV x       -> Ident x         AppV e1 e2     -> App (fuseRange e1 e2) e1 e2         OpAppV d ns es -> OpApp (fuseRange d es) d ns es@@ -95,22 +95,21 @@     patternView = isPattern  instance IsExpr Pattern where-    exprView e = case e of+    exprView = \case         IdentP x         -> LocalV x         AppP e1 e2       -> AppV e1 e2-        OpAppP r d ns es -> OpAppV d ns ((map . fmap . fmap)-                                           (noPlaceholder . Ordinary) es)+        OpAppP r d ns es -> OpAppV d ns $ (fmap . fmap . fmap) (noPlaceholder . Ordinary) es         HiddenP _ e      -> HiddenArgV e         InstanceP _ e    -> InstanceArgV e         ParenP _ e       -> ParenV e-        WildP{}          -> WildV e-        _                -> OtherV e-    unExprView e = case e of+        e@WildP{}        -> WildV e+        e                -> OtherV e+    unExprView = \case         LocalV x       -> IdentP x         AppV e1 e2     -> AppP e1 e2         OpAppV d ns es -> let ess :: [NamedArg Pattern]-                              ess = (map . fmap . fmap)-                                      (\x -> case x of+                              ess = (fmap . fmap . fmap)+                                      (\case                                           Placeholder{}     -> __IMPOSSIBLE__                                           NoPlaceholder _ x -> fromOrdinary __IMPOSSIBLE__ x)                                       es@@ -135,18 +134,18 @@  parse :: IsExpr e => (ParseSections, Parser e a) -> [e] -> [a] parse (DoNotParseSections, p) es = P.parse p (map noPlaceholder es)-parse (ParseSections,      p) es = P.parse p (concat $ map splitExpr es)+parse (ParseSections,      p) es = P.parse p (List1.concat $ map splitExpr es)   where-  splitExpr :: IsExpr e => e -> [MaybePlaceholder e]+  splitExpr :: IsExpr e => e -> List1 (MaybePlaceholder e)   splitExpr e = case exprView e of     LocalV n -> splitName n     _        -> noSplit     where-    noSplit = [noPlaceholder e]+    noSplit = singleton $ noPlaceholder e -    splitName n = case last ns of-      Name r nis ps@(_ : _ : _) -> splitParts r nis (init ns) Beginning ps-      _                         -> noSplit+    splitName n = case List1.last ns of+      Name r nis ps@(_ :| _ : _) -> splitParts r nis (List1.init ns) Beginning ps+      _                          -> noSplit       where       ns = qnameParts n @@ -157,16 +156,15 @@       -- Note also that the module qualifier, if any, is only applied       -- to the first name part. -      splitParts _ _   _ _ []          = __IMPOSSIBLE__-      splitParts _ _   _ _ (Hole : []) = [Placeholder End]-      splitParts r nis m _ (Id s : []) = [part r nis m End s]-      splitParts r nis m w (Hole : ps) = Placeholder w : splitParts r nis m  Middle ps-      splitParts r nis m w (Id s : ps) = part r nis m w s : splitParts r nis [] Middle ps+      splitParts _ _   _ _ (Hole :| [])     = singleton $ Placeholder End+      splitParts r nis m _ (Id s :| [])     = singleton $ part r nis m End s+      splitParts r nis m w (Hole :| p : ps) = Placeholder w    <| splitParts r nis m  Middle (p :| ps)+      splitParts r nis m w (Id s :| p : ps) = part r nis m w s <| splitParts r nis [] Middle (p :| ps)        part r nis m w s =         NoPlaceholder (Strict.Just w)                       (unExprView $ LocalV $-                         foldr Qual (QName (Name r nis [Id s])) m)+                         foldr Qual (QName $ Name r nis $ singleton $ Id s) m)  --------------------------------------------------------------------------- -- * Parser combinators@@ -181,7 +179,7 @@   doc (text (show str)) $   satNoPlaceholder isLocal   where-  str = prettyShow $ foldr Qual (QName $ Name noRange InScope [Id s]) ms+  str = prettyShow $ foldr Qual (QName $ simpleName s) ms   isLocal e = case exprView e of       LocalV y | str == prettyShow y -> Just $ getRange y       _ -> Nothing@@ -196,29 +194,29 @@ atLeastTwoParts :: IsExpr e => Parser e Name atLeastTwoParts =   (\p1 ps p2 ->-      let all = p1 : ps ++ [p2] in-      case mapMaybe fst all of-        (r,nis) : _ -> Name r nis (map snd all)+      let all = p1 :| ps ++ [p2] in+      case List1.mapMaybe fst all of+        (r,nis) : _ -> Name r nis (fmap snd all)         []          -> __IMPOSSIBLE__)   <$> part Beginning   <*> many (part Middle)   <*> part End   where-  part pos = sat' $ \tok -> case tok of+  part pos = sat' $ \case     Placeholder pos'                   | pos == pos' -> Just ( Nothing                                                              , Hole                                                              )     NoPlaceholder (Strict.Just pos') e | pos == pos' ->       case exprView e of-        LocalV (QName (Name r nis [Id s])) -> Just (Just (r,nis), Id s)-        _                                  -> Nothing+        LocalV (QName (Name r nis (Id s :| []))) -> Just (Just (r, nis), Id s)+        _ -> Nothing     _ -> Nothing  -- | Parses a potentially pattern-matching binder  patternBinder :: IsExpr e => Parser e Binder patternBinder = inOnePart <|> mkBinder_ <$> atLeastTwoParts-  where inOnePart = satNoPlaceholder $ \ e -> isBinderP =<< patternView e+  where inOnePart = satNoPlaceholder $ isBinderP <=< patternView  -- | Used to define the return type of 'opP'. @@ -248,11 +246,11 @@     => ParseSections     -> Parser e e -> NewNotation -> NK k -> Parser e (OperatorType k e) opP parseSections p (NewNotation q names _ syn isOp) kind =-  flip fmap (worker (init $ qnameParts q)+  flip fmap (worker (List1.init $ qnameParts q)                     withoutExternalHoles) $ \(range, hs) ->    let (normal, binders) = partitionEithers hs-      lastHole          = maximum $ mapMaybe holeTarget syn+      lastHole          = maximum $ (-1) : mapMaybe holeTarget syn        app :: ([(MaybePlaceholder e, NamedArg (Ranged Int))] ->               [(MaybePlaceholder e, NamedArg (Ranged Int))]) -> e@@ -308,7 +306,7 @@             p       <*> worker ms xs   worker ms (WildHole h : xs) =-    (\(r, es) -> let anon = mkBinder_ (Name noRange InScope [Hole])+    (\(r, es) -> let anon = mkBinder_ simpleHole                  in (r, Right (mkBinding h anon) : es))       <$> worker ms xs   worker ms (BindHole _ h : xs) = do@@ -329,13 +327,14 @@   findExprFor normalHoles binders n =     case [ h | h@(_, m) <- normalHoles, rangedThing (namedArg m) == n ] of       [(Placeholder p,     arg)] -> set (Placeholder p) arg-      [(NoPlaceholder _ e, arg)] -> case [b | (b, m) <- binders, rangedThing m == n] of-        [] -> set (noPlaceholder (Ordinary e)) arg -- no variable to bind-        bs -> set (noPlaceholder (SyntaxBindingLambda (fuseRange bs e) bs e)) arg+      [(NoPlaceholder _ e, arg)] ->+        List1.ifNull [ b | (b, m) <- binders, rangedThing m == n ]+        {-then-} (set (noPlaceholder (Ordinary e)) arg) -- no variable to bind+        {-else-} $ \ bs -> set (noPlaceholder (SyntaxBindingLambda (fuseRange bs e) bs e)) arg       _ -> __IMPOSSIBLE__ -  noPlaceholders :: [NamedArg (MaybePlaceholder (OpApp e))] -> Int-  noPlaceholders = sum . map (isPlaceholder . namedArg)+  noPlaceholders :: OpAppArgs' e -> Int+  noPlaceholders = sum . fmap (isPlaceholder . namedArg)     where     isPlaceholder NoPlaceholder{} = 0     isPlaceholder Placeholder{}   = 1

src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs view

@@ -2,8 +2,7 @@ -- | The parser monad used by the operator parser ------------------------------------------------------------------------ -{-# LANGUAGE CPP           #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-}  module Agda.Syntax.Concrete.Operators.Parser.Monad   ( MemoKey(..), PrecedenceKey

src/full/Agda/Syntax/Concrete/Pattern.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-}  -- For type equality.  -- | Tools for patterns in concrete syntax. @@ -9,19 +8,18 @@ import Control.Monad.Identity import Control.Monad.Writer -import Data.Foldable    (Foldable, foldMap)-import Data.Traversable (Traversable, traverse)-import Data.Monoid- import Agda.Syntax.Common import Agda.Syntax.Concrete-import Agda.Syntax.Position  import Agda.Utils.AffineHole import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.List+import Agda.Utils.List1  ( List1, pattern (:|) )+import Agda.Utils.List2  ( List2 ) import Agda.Utils.Maybe+import Agda.Utils.Singleton+import qualified Agda.Utils.List1 as List1   -- | Check for ellipsis @...@.@@ -32,9 +30,8 @@ -- | Is the pattern just @...@? instance IsEllipsis Pattern where   isEllipsis = \case-    EllipsisP{}   -> True-    RawAppP _ [p] -> isEllipsis p-    ParenP _ p    -> isEllipsis p+    EllipsisP{}         -> True+    ParenP _ p          -> isEllipsis p     _ -> False  -- | Has the lhs an occurrence of the ellipsis @...@?@@ -51,7 +48,7 @@  -- | Does the lhs contain an ellipsis? instance HasEllipsis LHS where-  hasEllipsis (LHS p _ _ _) = hasEllipsis p+  hasEllipsis (LHS p _ _) = hasEllipsis p   -- clauses that are already expanded don't have an ellipsis  -- | Check for with-pattern @| p@.@@ -64,9 +61,8 @@  instance IsWithP Pattern where   isWithP = \case-    WithP _ p     -> Just p-    RawAppP _ [p] -> isWithP p-    ParenP _ p    -> isWithP p+    WithP _ p           -> Just p+    ParenP _ p          -> isWithP p     _ -> Nothing  instance IsWithP p => IsWithP (Arg p) where@@ -136,6 +132,7 @@   LHSHead{}     -> False   LHSProj{}     -> True   LHSWith h _ _ -> hasCopatterns h+  LHSEllipsis{} -> False  -- * Generic fold @@ -194,15 +191,15 @@       AsP _ _ p       -> foldrCPattern f p       WithP _ p       -> foldrCPattern f p       RecP _ ps       -> foldrCPattern f ps+      EllipsisP _ mp  -> foldrCPattern f mp       -- Nonrecursive cases:       IdentP _        -> mempty       WildP _         -> mempty       DotP _ _        -> mempty       AbsurdP _       -> mempty-      LitP _          -> mempty+      LitP _ _        -> mempty       QuoteP _        -> mempty       EqualP _ _      -> mempty-      EllipsisP _     -> mempty    traverseCPatternA f p0 = f p0 $ case p0 of       -- Recursive cases:@@ -215,15 +212,15 @@       AsP       r x p     -> AsP r x       <$> traverseCPatternA f p       WithP     r p       -> WithP r       <$> traverseCPatternA f p       RecP      r ps      -> RecP r        <$> traverseCPatternA f ps+      EllipsisP r mp      -> EllipsisP r   <$> traverseCPatternA f mp       -- Nonrecursive cases:       IdentP _        -> pure p0       WildP _         -> pure p0       DotP _ _        -> pure p0       AbsurdP _       -> pure p0-      LitP _          -> pure p0+      LitP _ _        -> pure p0       QuoteP _        -> pure p0       EqualP _ _      -> pure p0-      EllipsisP _     -> pure p0    traverseCPatternM pre post = pre >=> recurse >=> post     where@@ -238,15 +235,15 @@       AsP       r x p     -> AsP r x       <$> traverseCPatternM pre post p       WithP     r p       -> WithP r       <$> traverseCPatternM pre post p       RecP      r ps      -> RecP r        <$> traverseCPatternM pre post ps+      EllipsisP r mp      -> EllipsisP r   <$> traverseCPatternM pre post mp       -- Nonrecursive cases:       IdentP _        -> return p0       WildP _         -> return p0       DotP _ _        -> return p0       AbsurdP _       -> return p0-      LitP _          -> return p0+      LitP _ _        -> return p0       QuoteP _        -> return p0       EqualP _ _      -> return p0-      EllipsisP _     -> return p0  instance (CPatternLike a, CPatternLike b) => CPatternLike (a,b) where   foldrCPattern f (p, p') =@@ -262,11 +259,13 @@       (traverseCPatternM pre post p)       (traverseCPatternM pre post p') -instance CPatternLike p => CPatternLike (Arg p)              where-instance CPatternLike p => CPatternLike (Named n p)          where-instance CPatternLike p => CPatternLike [p]                  where-instance CPatternLike p => CPatternLike (Maybe p)            where-instance CPatternLike p => CPatternLike (FieldAssignment' p) where+instance CPatternLike p => CPatternLike (Arg p)+instance CPatternLike p => CPatternLike (Named n p)+instance CPatternLike p => CPatternLike [p]+instance CPatternLike p => CPatternLike (List1 p)+instance CPatternLike p => CPatternLike (List2 p)+instance CPatternLike p => CPatternLike (Maybe p)+instance CPatternLike p => CPatternLike (FieldAssignment' p)  -- | Compute a value from each subpattern and collect all values in a monoid. @@ -316,12 +315,12 @@     WildP _        -> mempty     AbsurdP _      -> mempty     DotP _ _       -> mempty-    LitP _         -> mempty+    LitP _ _       -> mempty     QuoteP _       -> mempty     InstanceP _ _  -> mempty     RecP _ _       -> mempty     EqualP _ _     -> mempty-    EllipsisP _    -> mempty+    EllipsisP _ _  -> mempty  -- | Get all the identifiers in a pattern in left-to-right order. patternNames :: Pattern -> [Name]@@ -345,18 +344,20 @@  -- | Compute the context in which the ellipsis occurs, if at all. --   If there are several occurrences, this is an error.+--   This only counts ellipsis that haven't already been expanded. hasEllipsis' :: CPatternLike p => p -> AffineHole Pattern p hasEllipsis' = traverseCPatternA $ \ p mp ->   case p of-    EllipsisP{} -> OneHole id p-    _           -> mp+    EllipsisP _ Nothing -> OneHole id p+    _                   -> mp  reintroduceEllipsis :: ExpandedEllipsis -> Pattern -> Pattern-reintroduceEllipsis NoEllipsis p = p-reintroduceEllipsis (ExpandedEllipsis r k) p =-  let core  = EllipsisP r-      wargs = snd $ splitEllipsis k $ patternAppView p-  in foldl AppP core wargs+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+  in foldl AppP (EllipsisP r $ Just $ core) wargs+reintroduceEllipsis _ p = p  splitEllipsis :: (IsWithP p) => Int -> [p] -> ([p],[p]) splitEllipsis k [] = ([] , [])@@ -374,10 +375,10 @@ --   (in most cases a constructor). -- --  Pattern needs to be parsed already (operators resolved).-patternAppView :: Pattern -> [NamedArg Pattern]-patternAppView p = case p of-    AppP p arg      -> patternAppView p ++ [arg]-    OpAppP _ x _ ps -> defaultNamedArg (IdentP x) : ps+patternAppView :: Pattern -> List1 (NamedArg Pattern)+patternAppView = \case+    AppP p arg      -> patternAppView p `List1.append` [arg]+    OpAppP _ x _ ps -> defaultNamedArg (IdentP x) :| ps     ParenP _ p      -> patternAppView p     RawAppP _ _     -> __IMPOSSIBLE__-    _               -> [ defaultNamedArg p ]+    p               -> singleton $ defaultNamedArg p

src/full/Agda/Syntax/Concrete/Pretty.hs view

@@ -3,36 +3,36 @@  {-| Pretty printer for the concrete syntax. -}-module Agda.Syntax.Concrete.Pretty where+module Agda.Syntax.Concrete.Pretty+  ( module Agda.Syntax.Concrete.Pretty+  , module Agda.Syntax.Concrete.Glyph+  ) where  import Prelude hiding ( null ) -import Data.IORef 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.Fixity-import Agda.Syntax.Notation import Agda.Syntax.Position--import Agda.Interaction.Options.IORefs (UnicodeOrAscii(..), unicodeOrAscii)+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 qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import Agda.Utils.Null import Agda.Utils.Pretty-import Agda.Utils.String  import Agda.Utils.Impossible -import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)---- Andreas, 2017-10-02, TODO: restore Show to its original purpose--- deriving instance Show Expr deriving instance (Show a) => Show (OpApp a) deriving instance Show Declaration@@ -53,80 +53,7 @@ deriving instance Show WhereClause deriving instance Show ModuleApplication deriving instance Show DoStmt---- instance Show Expr            where show = show . pretty--- instance Show Declaration     where show = show . pretty--- instance Show Pattern         where show = show . pretty--- instance Show TypedBinding    where show = show . pretty--- instance Show LamBinding      where show = show . pretty--- instance (Pretty a, Pretty b) => Show (ImportDirective' a b)---                               where show = show . pretty--- instance Show Pragma          where show = show . pretty--- instance Show RHS             where show = show . pretty--- instance Show LHS where show = show . pretty--- instance Show LHSCore where show = show . pretty--- instance Show WhereClause where show = show . pretty--- instance Show ModuleApplication where show = show . pretty----- | 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-  , _leftIdiomBrkt  :: Doc-  , _rightIdiomBrkt :: Doc-  , _emptyIdiomBrkt :: Doc-  }--{-# NOINLINE specialCharacters #-}-specialCharacters :: SpecialCharacters-specialCharacters =-  let opt = UNSAFE.unsafePerformIO (readIORef unicodeOrAscii) in-  case opt of-    UnicodeOk -> SpecialCharacters { _dbraces = (("\x2983 " <>) . (<> " \x2984"))-                                   , _lambda  = "\x03bb"-                                   , _arrow   = "\x2192"-                                   , _forallQ = "\x2200"-                                   , _leftIdiomBrkt  = "\x2987"-                                   , _rightIdiomBrkt = "\x2988"-                                   , _emptyIdiomBrkt = "\x2987\x2988"-                                   }-    AsciiOnly -> SpecialCharacters { _dbraces = braces . braces'-                                   , _lambda  = "\\"-                                   , _arrow   = "->"-                                   , _forallQ = "forall"-                                   , _leftIdiomBrkt  = "(|"-                                   , _rightIdiomBrkt = "|)"-                                   , _emptyIdiomBrkt = "(|)"-                                   }--braces' :: Doc -> Doc-braces' d = ifNull (render d) (braces d) {-else-} $ \ s ->-  braces (spaceIfDash (head s) <> d <> spaceIfDash (last s))-  -- Add space to avoid starting a comment (Ulf, 2010-09-13, #269)-  -- Andreas, 2018-07-21, #3161: Also avoid ending a comment-  where-  spaceIfDash '-' = " "-  spaceIfDash _   = empty---- double braces...-dbraces :: Doc -> Doc-dbraces = _dbraces specialCharacters---- forall quantifier-forallQ :: Doc-forallQ = _forallQ specialCharacters---- left, right, and empty idiom bracket-leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt :: Doc-leftIdiomBrkt  = _leftIdiomBrkt  specialCharacters-rightIdiomBrkt = _rightIdiomBrkt specialCharacters-emptyIdiomBrkt = _emptyIdiomBrkt specialCharacters+deriving instance Show Module  -- Lays out a list of documents [d₁, d₂, …] in the following way: -- @@@ -137,14 +64,10 @@ -- @ -- If the list is empty, then the notation @{}@ is used. -bracesAndSemicolons :: [Doc] -> Doc-bracesAndSemicolons []       = "{}"-bracesAndSemicolons (d : ds) =-  sep (["{" <+> d] ++ map (";" <+>) ds ++ ["}"])--arrow, lambda :: Doc-arrow  = _arrow specialCharacters-lambda = _lambda specialCharacters+bracesAndSemicolons :: Foldable t => t Doc -> Doc+bracesAndSemicolons ts = case Fold.toList ts of+  []       -> "{}"+  (d : ds) -> sep (["{" <+> d] ++ map (";" <+>) ds ++ ["}"])  -- | @prettyHiding info visible doc@ puts the correct braces --   around @doc@ according to info @info@ and returns@@ -164,6 +87,9 @@ prettyQuantity a d =   if render d == "_" then d else pretty (getQuantity a) <+> d +prettyErased :: Erased -> Doc -> Doc+prettyErased = prettyQuantity . asQuantity+ prettyCohesion :: LensCohesion a => a -> Doc -> Doc prettyCohesion a d =   if render d == "_" then d else pretty (getCohesion a) <+> d@@ -218,6 +144,13 @@   pretty Continuous = mempty   pretty Squash  = "@⊤" +instance Pretty Modality where+  pretty mod = hsep+    [ pretty (getRelevance mod)+    , pretty (getQuantity mod)+    , pretty (getCohesion mod)+    ]+ instance Pretty (OpApp Expr) where   pretty (Ordinary e) = pretty e   pretty (SyntaxBindingLambda r bs e) = pretty (Lam r bs e)@@ -230,7 +163,7 @@     pretty e =         case e of             Ident x          -> pretty x-            Lit l            -> pretty l+            Lit _ l          -> pretty l             QuestionMark _ n -> "?" <> maybe empty (text . show) n             Underscore _ n   -> maybe underscore text n             App _ _ _        ->@@ -240,7 +173,7 @@ --                      sep [ pretty e1 --                          , nest 2 $ fsep $ map pretty args --                          ]-            RawApp _ es    -> fsep $ map pretty es+            RawApp _ es    -> fsep $ map pretty $ List2.toList es             OpApp _ q _ es -> fsep $ prettyOpApp q es              WithApp _ e es -> fsep $@@ -248,27 +181,25 @@              HiddenArg _ e -> braces' $ pretty e             InstanceArg _ e -> dbraces $ pretty e-            Lam _ bs (AbsurdLam _ h) -> lambda <+> fsep (map pretty bs) <+> absurd h+            Lam _ bs (AbsurdLam _ h) -> lambda <+> fsep (fmap pretty bs) <+> absurd h             Lam _ bs e ->-                sep [ lambda <+> fsep (map pretty bs) <+> arrow+                sep [ lambda <+> fsep (fmap pretty bs) <+> arrow                     , nest 2 $ pretty e                     ]             AbsurdLam _ h -> lambda <+> absurd h-            ExtendedLam _ pes -> lambda <+> bracesAndSemicolons (map pretty pes)+            ExtendedLam _ e pes ->+              lambda <+>+              prettyErased e (bracesAndSemicolons (fmap pretty pes))             Fun _ e1 e2 ->                 sep [ prettyCohesion e1 (prettyQuantity e1 (pretty e1)) <+> arrow                     , pretty e2                     ]             Pi tel e ->-                sep [ pretty (Tel $ smashTel tel) <+> arrow+                sep [ pretty (Tel $ smashTel $ List1.toList tel) <+> arrow                     , pretty e                     ]-            Set _   -> "Set"-            Prop _  -> "Prop"-            SetN _ n    -> "Set" <> text (showIndex n)-            PropN _ n   -> "Prop" <> text (showIndex n)             Let _ ds me  ->-                sep [ "let" <+> vcat (map pretty ds)+                sep [ "let" <+> vcat (fmap pretty ds)                     , maybe empty (\ e -> "in" <+> pretty e) me                     ]             Paren _ e -> parens $ pretty e@@ -277,7 +208,7 @@                 []   -> emptyIdiomBrkt                 [e]  -> leftIdiomBrkt <+> pretty e <+> rightIdiomBrkt                 e:es -> leftIdiomBrkt <+> pretty e <+> fsep (map (("|" <+>) . pretty) es) <+> rightIdiomBrkt-            DoBlock _ ss -> "do" <+> vcat (map pretty ss)+            DoBlock _ ss -> "do" <+> vcat (fmap pretty ss)             As _ x e  -> pretty x <> "@" <> pretty e             Dot _ e   -> "." <> pretty e             DoubleDot _ e  -> ".." <> pretty e@@ -308,13 +239,13 @@   pretty (FieldAssignment x e) = sep [ pretty x <+> "=" , nest 2 $ pretty e ]  instance Pretty ModuleAssignment where-  pretty (ModuleAssignment m es i) = (fsep $ pretty m : map pretty es) <+> pretty i+  pretty (ModuleAssignment m es i) = fsep (pretty m : map pretty es) <+> pretty i  instance Pretty LamClause where-  pretty (LamClause lhs rhs wh _) =-    sep [ pretty lhs+  pretty (LamClause ps rhs _) =+    sep [ fsep (map pretty ps)         , nest 2 $ pretty' rhs-        ] $$ nest 2 (pretty wh)+        ]     where       pretty' (RHS e)   = arrow <+> pretty e       pretty' AbsurdRHS = empty@@ -363,9 +294,9 @@     pretty (DomainFull b) = pretty b  instance Pretty TypedBinding where-    pretty (TLet _ ds) = parens $ "let" <+> vcat (map pretty ds)+    pretty (TLet _ ds) = parens $ "let" <+> vcat (fmap pretty ds)     pretty (TBind _ xs (Underscore _ Nothing)) =-      fsep (map (pretty . NamedBinding True) xs)+      fsep (fmap (pretty . NamedBinding True) xs)     pretty (TBind _ xs e) = fsep       [ prettyRelevance y         $ prettyHiding y parens@@ -374,7 +305,7 @@         $ prettyTactic (binderName $ namedArg y) $         sep [ fsep (map (pretty . NamedBinding False) ys)             , ":" <+> pretty e ]-      | ys@(y : _) <- groupBinds xs ]+      | ys@(y : _) <- groupBinds $ List1.toList xs ]       where         groupBinds [] = []         groupBinds (x : xs)@@ -396,7 +327,7 @@ smashTel :: Telescope -> Telescope smashTel (TBind r xs e  :           TBind _ ys e' : tel)-  | show e == show e' = smashTel (TBind r (xs ++ ys) e : tel)+  | prettyShow e == prettyShow e' = smashTel (TBind r (xs Semigroup.<> ys) e : tel) smashTel (b : tel) = b : smashTel tel smashTel [] = [] @@ -407,22 +338,29 @@  instance Pretty WhereClause where   pretty  NoWhere = empty-  pretty (AnyWhere [Module _ x [] ds]) | isNoName (unqualify x)+  pretty (AnyWhere _ [Module _ x [] ds]) | isNoName (unqualify x)                        = vcat [ "where", nest 2 (vcat $ map pretty ds) ]-  pretty (AnyWhere ds) = vcat [ "where", nest 2 (vcat $ map pretty ds) ]-  pretty (SomeWhere m a ds) =+  pretty (AnyWhere _ ds) = vcat [ "where", nest 2 (vcat $ map pretty ds) ]+  pretty (SomeWhere _ m a ds) =     vcat [ hsep $ applyWhen (a == PrivateAccess UserWritten) ("private" :)              [ "module", pretty m, "where" ]          , nest 2 (vcat $ map pretty ds)          ]  instance Pretty LHS where-  pretty (LHS p eqs es ell) = sep+  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 pretty es)-    ]+    , nest 2 $ prefixedThings "with" (map prettyWithd es)+    ] where +    prettyWithd :: WithExpr -> Doc+    prettyWithd (Named nm wh) =+      let e = pretty wh in+      case nm of+        Nothing -> e+        Just n  -> pretty n <+> ":" <+> e+ instance Pretty LHSCore where   pretty (LHSHead f ps) = sep $ pretty f : map (parens . pretty) ps   pretty (LHSProj d ps lhscore ps') = sep $@@ -432,6 +370,7 @@       sep $ parens doc : map (parens . pretty) ps     where     doc = sep $ pretty h : map (("|" <+>) . pretty) wps+  pretty (LHSEllipsis r p) = "..."  instance Pretty ModuleApplication where   pretty (SectionApp _ bs e) = fsep (map pretty bs) <+> "=" <+> pretty e@@ -444,7 +383,7 @@       prCs [] = empty       prCs cs = "where" <?> vcat (map pretty cs)   pretty (DoThen e) = pretty e-  pretty (DoLet _ ds) = "let" <+> vcat (map pretty ds)+  pretty (DoLet _ ds) = "let" <+> vcat (fmap pretty ds)  instance Pretty Declaration where     prettyList = vcat . map pretty@@ -514,16 +453,19 @@                             , pretty e                             ]                     ]-            Record _ x ind eta con tel e cs ->-              pRecord x ind eta con tel (Just e) cs-            RecordDef _ x ind eta con tel cs ->-              pRecord x ind eta con tel Nothing cs+            Record _ x dir tel e cs ->+              pRecord x dir tel (Just e) cs+            RecordDef _ x dir tel cs ->+              pRecord x dir tel Nothing cs+            RecordDirective r -> pRecordDirective r             Infix f xs  ->-                pretty f <+> (fsep $ punctuate comma $ map pretty xs)+                pretty f <+> fsep (punctuate comma $ fmap pretty xs)             Syntax n xs -> "syntax" <+> pretty n <+> "..."             PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as)                                      <+> "=" <+> pretty p             Mutual _ ds     -> namedBlock "mutual" ds+            InterleavedMutual _ ds  -> namedBlock "interleaved mutual" ds+            LoneConstructor _ ds -> namedBlock "constructor" ds             Abstract _ ds   -> namedBlock "abstract" ds             Private _ _ ds  -> namedBlock "private" ds             InstanceB _ ds  -> namedBlock "instance" ds@@ -567,17 +509,44 @@                     , nest 2 $ vcat $ map pretty ds                     ] -pRecord :: Name -> Maybe (Ranged Induction) -> Maybe HasEta -> Maybe (Name, IsInstance) -> [LamBinding] -> Maybe Expr -> [Declaration] -> Doc-pRecord x ind eta con tel me cs =-  sep [ hsep  [ "record"+pHasEta0 :: HasEta0 -> Doc+pHasEta0 = \case+  YesEta   -> "eta-equality"+  NoEta () -> "no-eta-equality"++pRecordDirective :: RecordDirective -> Doc+pRecordDirective = \case+  Induction ind -> pretty (rangedThing ind)+  Constructor n inst -> hsep [ pInst, "constructor", pretty n ] where+    pInst = case inst of+      InstanceDef{} -> "instance"+      NotInstanceDef{} -> empty+  Eta eta -> pHasEta0 (rangedThing eta)+  PatternOrCopattern{} -> "pattern"++pRecord+  :: Name+  -> RecordDirectives+  -> [LamBinding]+  -> Maybe Expr+  -> [Declaration]+  -> Doc+pRecord x (RecordDirectives ind eta pat con) tel me ds = vcat+    [ sep+      [ hsep  [ "record"               , pretty x               , fcat (map pretty tel)               ]       , nest 2 $ pType me-      ] $$ nest 2 (vcat $ pInd ++-                          pEta ++-                          pCon ++-                          map pretty cs)+      ]+    , nest 2 $ vcat $ concat+      [ pInd+      , pEta+      , pPat+      , pCon+      , map pretty ds+      ]+    ]   where pType (Just e) = hsep                 [ ":"                 , pretty e@@ -585,10 +554,15 @@                 ]         pType Nothing  =                   "where"-        pInd = maybeToList $ text . show . rangedThing <$> ind-        pEta = maybeToList $ eta <&> \case-          YesEta -> "eta-equality"-          NoEta  -> "no-eta-equality"+        pInd = maybeToList $ pretty . rangedThing <$> ind+        pEta = maybeToList $ eta <&> pHasEta0+        pPat = maybeToList $ "pattern" <$ pat+        -- pEta = caseMaybe eta [] $ \case+        --   YesEta -> [ "eta-equality" ]+        --   NoEta  -> "no-eta-equality" : pPat+        -- pPat = \case+        --   PatternMatching   -> [ "pattern" ]+        --   CopatternMatching -> []         pCon = maybeToList $ (("constructor" <+>) . pretty) . fst <$> con  instance Pretty OpenShortHand where@@ -612,8 +586,8 @@       hsep $ ["INLINE", pretty i]     pretty (InlinePragma _ False i) =       hsep $ ["NOINLINE", pretty i]-    pretty (ImpossiblePragma _) =-      hsep $ ["IMPOSSIBLE"]+    pretty (ImpossiblePragma _ strs) =+      hsep $ ["IMPOSSIBLE"] ++ map text strs     pretty (EtaPragma _ x) =       hsep $ ["ETA", pretty x]     pretty (TerminationCheckPragma _ tc) =@@ -624,8 +598,8 @@         Terminating            -> "TERMINATING"         TerminationMeasure _ x -> hsep $ ["MEASURE", pretty x]     pretty (NoCoverageCheckPragma _) = "NON_COVERING"-    pretty (WarningOnUsage _ nm str) = hsep [ "WARNING_ON_USAGE", pretty nm, text str ]-    pretty (WarningOnImport _ str)   = hsep [ "WARNING_ON_IMPORT", text str ]+    pretty (WarningOnUsage _ nm str) = hsep [ "WARNING_ON_USAGE", pretty nm, text (T.unpack str) ]+    pretty (WarningOnImport _ str)   = hsep [ "WARNING_ON_IMPORT", text (T.unpack str) ]     pretty (CatchallPragma _) = "CATCHALL"     pretty (DisplayPragma _ lhs rhs) = "DISPLAY" <+> sep [ pretty lhs <+> "=", nest 2 $ pretty rhs ]     pretty (NoPositivityCheckPragma _) = "NO_POSITIVITY_CHECK"@@ -633,14 +607,21 @@       hsep ("POLARITY" : pretty q : map pretty occs)     pretty (NoUniverseCheckPragma _) = "NO_UNIVERSE_CHECK" +instance Pretty Associativity where+  pretty = \case+    LeftAssoc  -> "infixl"+    RightAssoc -> "infixr"+    NonAssoc   -> "infix"++instance Pretty FixityLevel where+  pretty = \case+    Unrelated  -> empty+    Related d  -> text $ toStringWithoutDotZero d+ instance Pretty Fixity where-    pretty (Fixity _ Unrelated   _)   = __IMPOSSIBLE__-    pretty (Fixity _ (Related d) ass) = s <+> text (toStringWithoutDotZero d)-      where-      s = case ass of-            LeftAssoc  -> "infixl"-            RightAssoc -> "infixr"-            NonAssoc   -> "infix"+  pretty (Fixity _ level ass) = case level of+    Unrelated  -> empty+    Related{}  -> pretty ass <+> pretty level  instance Pretty GenPart where     pretty (IdPart x)   = text $ rangedThing x@@ -651,9 +632,9 @@     prettyList = hcat . map pretty  instance Pretty Fixity' where-    pretty (Fixity' fix nota _)-      | nota == noNotation = pretty fix-      | otherwise          = "syntax" <+> pretty nota+    pretty (Fixity' fix nota _range)+      | null nota = pretty fix+      | otherwise = "syntax" <+> pretty nota   -- Andreas 2010-09-21: do not print relevance in general, only in function types!  -- Andreas 2010-09-24: and in record fields@@ -674,8 +655,8 @@     pretty = \case             IdentP x        -> pretty x             AppP p1 p2      -> sep [ pretty p1, nest 2 $ pretty p2 ]-            RawAppP _ ps    -> fsep $ map pretty ps-            OpAppP _ q _ ps -> fsep $ prettyOpApp q (fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps)+            RawAppP _ ps    -> fsep $ map pretty $ List2.toList ps+            OpAppP _ q _ ps -> fsep $ prettyOpApp q $ fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps             HiddenP _ p     -> braces' $ pretty p             InstanceP _ p   -> dbraces $ pretty p             ParenP _ p      -> parens $ pretty p@@ -683,11 +664,11 @@             AsP _ x p       -> pretty x <> "@" <> pretty p             DotP _ p        -> "." <> pretty p             AbsurdP _       -> "()"-            LitP l          -> pretty l+            LitP _ l        -> pretty l             QuoteP _        -> "quote"             RecP _ fs       -> sep [ "record", bracesAndSemicolons (map pretty fs) ]             EqualP _ es     -> sep $ [ parens (sep [pretty e1, "=", pretty e2]) | (e1,e2) <- es ]-            EllipsisP _     -> "..."+            EllipsisP _ mp  -> "..."             WithP _ p       -> "|" <+> pretty p  prettyOpApp :: forall a .@@ -695,10 +676,10 @@ prettyOpApp q es = merge [] $ prOp ms xs es   where     -- ms: the module part of the name.-    ms = init (qnameParts q)+    ms = List1.init (qnameParts q)     -- xs: the concrete name (alternation of @Id@ and @Hole@)     xs = case unqualify q of-           Name _ _ xs    -> xs+           Name _ _ xs    -> List1.toList xs            NoName{}       -> __IMPOSSIBLE__      prOp :: [Name] -> [NamePart] -> [NamedArg (MaybePlaceholder a)] -> [(Doc, Maybe PositionInName)]@@ -708,7 +689,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 $ pretty $ Name noRange InScope $ [Id x]+    prOp ms (Id x : xs) es       = ( qual ms $ pretty $ simpleName x                                    , Nothing                                    ) : prOp [] xs es       -- Qualify the name part with the module.

src/full/Agda/Syntax/DoNotation.hs view

@@ -35,13 +35,18 @@ import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad -import Agda.Utils.Pretty ( prettyShow ) import Agda.Utils.List   ( initMaybe )+import Agda.Utils.List1  ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Singleton -desugarDoNotation :: Range -> [DoStmt] -> ScopeM Expr+import Agda.Utils.Impossible++desugarDoNotation :: Range -> List1 DoStmt -> ScopeM Expr desugarDoNotation r ss = do-  let qBind = QName $ Name noRange InScope [Hole, Id ">>=", Hole]-      qThen = QName $ Name noRange InScope [Hole, Id ">>", Hole]+  let qBind = QName $ simpleBinaryOperator ">>="+      qThen = QName $ simpleBinaryOperator ">>"       isBind DoBind{} = True       isBind _        = False       isThen DoThen{} = True@@ -51,72 +56,78 @@   -- I think we should throw an error rather than silently switching to _>>=_.   -- / Ulf   mapM_ ensureInScope $ [qBind | any isBind ss] ++-                        [qThen | any isThen $ fromMaybe ss $ initMaybe ss] -- ignore the last 'DoThen'+                        [qThen | any isThen $ List1.init ss] -- ignore the last 'DoThen'   desugarDo qBind qThen ss -desugarDo :: QName -> QName -> [DoStmt] -> ScopeM Expr+desugarDo :: QName -> QName -> List1 DoStmt -> ScopeM Expr+desugarDo qBind qThen = \case --- The parser doesn't generate empty 'do' blocks at the moment, but if that--- changes throwing the error is the right thing to do.-desugarDo qBind qThen [] = genericError "Empty 'do' block"+  -- The last statement must be a DoThen.+  DoThen e        :| [] -> return e --- The last statement must be a DoThen-desugarDo qBind qThen [s]-  | DoThen e              <- s           = return e-  | DoBind r p e []       <- s-  , Just (r' , NotHidden) <- isAbsurdP p =-      return $ appOp (setRange r qBind) e $ AbsurdLam r' NotHidden-  | otherwise                            =-      genericError "The last statement in a 'do' block must be an expression or an absurd match."+  -- Or an absurd bind.+  DoBind r p e [] :| [] | Just (r', NotHidden) <- isAbsurdP p ->+    return $ appOp (setRange r qBind) e $ AbsurdLam r' NotHidden --- `DoThen` and `DoLet` are easy-desugarDo qBind qThen (DoThen e   : ss) = appOp qThen e   <$> desugarDo qBind qThen ss-desugarDo qBind qThen (DoLet r ds : ss) = Let r ds . Just <$> desugarDo qBind qThen ss+  -- Otherwise, sorry.+  _ :| [] -> failure --- `DoBind` requires more work since we want to generate plain lambdas when--- possible.-desugarDo qBind qThen (DoBind r p e [] : ss)-  | Just x <- singleName p = do-  -- In this case we have a single name in the bind pattern and no where clauses.-  -- It could still be a pattern bind though (for instance, `refl ← pure eq`), so-  -- to figure out which one to use we look up the name in the scope; if it's a-  -- constructor or pattern synonym we desugar to a pattern lambda.-  res <- resolveName (QName x)-  let isMatch = case res of-        ConstructorName{}   -> True-        PatternSynResName{} -> True-        _                   -> False-  rest <- desugarDo qBind qThen ss-  if isMatch then return $ matchingBind qBind r p e rest []-             else return $ nonMatchingBind qBind r x e rest-desugarDo qBind qThen (DoBind r p e cs : ss) = do-  -- If there are where clauses we have to desugar to a pattern lambda.-  rest <- desugarDo qBind qThen ss-  return $ matchingBind qBind r p e rest cs+  -- `DoThen` and `DoLet` are easy.+  DoThen e   :| ss -> appOp qThen e   <$> desugarDo0 ss+  DoLet r ds :| ss -> Let r ds . Just <$> desugarDo0 ss +  -- `DoBind` requires more work since we want to generate plain lambdas when possible.+  DoBind r p e [] :| ss | Just x <- singleName p -> do+    -- In this case we have a single name in the bind pattern and no where clauses.+    -- It could still be a pattern bind though (for instance, `refl ← pure eq`), so+    -- to figure out which one to use we look up the name in the scope; if it's a+    -- constructor or pattern synonym we desugar to a pattern lambda.+    res <- resolveName (QName x)+    let isMatch = case res of+          ConstructorName{}   -> True+          PatternSynResName{} -> True+          _                   -> False+    rest <- desugarDo0 ss+    if isMatch then return $ matchingBind qBind r p e rest []+               else return $ nonMatchingBind qBind r x e rest++  -- If there are @where@ clauses we have to desugar to a pattern lambda.+  DoBind r p e cs :| ss -> do+    rest <- desugarDo0 ss+    return $ matchingBind qBind r p e rest cs++  where+  desugarDo0 :: [DoStmt] -> ScopeM Expr+  desugarDo0 ss = List1.ifNull ss failure $ desugarDo qBind qThen++  failure = genericError+    "The last statement in a 'do' block must be an expression or an absurd match."+ singleName :: Pattern -> Maybe Name-singleName (IdentP (QName x)) = Just x-singleName (RawAppP _ [p])    = singleName p-singleName _                  = Nothing+singleName = \case+  IdentP (QName x) -> Just x+  _ -> Nothing  matchingBind :: QName -> Range -> Pattern -> Expr -> Expr -> [LamClause] -> Expr matchingBind qBind r p e body cs =-  appOp (setRange r qBind) e          -- Set the range of the lambda to that of the-    $ ExtendedLam (getRange cs)       -- where-clauses to make highlighting of overlapping-    $ map addParens (mainClause : cs) -- patterns not highlight the rest of the do-block.+  appOp (setRange r qBind) e             -- Set the range of the lambda to that of the+    $ ExtendedLam (getRange cs)          -- where-clauses to make highlighting of overlapping+        defaultErased                    -- patterns not highlight the rest of the do-block.+    $ fmap addParens (mainClause :| cs)   where-    mainClause = LamClause { lamLHS      = LHS p [] [] NoEllipsis+    mainClause = LamClause { lamLHS      = [p]                            , lamRHS      = RHS body-                           , lamWhere    = NoWhere                            , lamCatchAll = False } -    -- Add parens to left-hand sides: there can only be one pattern in these clauses.+    -- Add parens to left-hand sides.     addParens c = c { lamLHS = addP (lamLHS c) }-      where addP (LHS p rw we ell) = LHS (RawAppP noRange [ParenP noRange p]) rw we ell+      where+      addP []           = __IMPOSSIBLE__+      addP pps@(p : ps) = [ParenP (getRange pps) $ rawAppP $ p :| ps ]  nonMatchingBind :: QName -> Range -> Name -> Expr -> Expr -> Expr nonMatchingBind qBind r x e body =-    appOp (setRange r qBind) e $ Lam (getRange (x, body)) [bx] body+    appOp (setRange r qBind) e $ Lam (getRange (x, body)) (singleton bx) body   where bx = DomainFree $ defaultNamedArg $ mkBinder_ x  appOp :: QName -> Expr -> Expr -> Expr

src/full/Agda/Syntax/Fixity.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}  {-| Definitions for fixity, precedence levels, and declared syntax. -}@@ -6,16 +5,13 @@  import Control.DeepSeq -import qualified Data.List as List-import Data.Maybe- import Data.Data (Data) +import GHC.Generics (Generic)+ import Agda.Syntax.Position import Agda.Syntax.Common-import Agda.Syntax.Notation -import Agda.Utils.List import Agda.Utils.Pretty  import Agda.Utils.Impossible@@ -36,8 +32,10 @@ -- | Do we prefer parens around arguments like @λ x → x@ or not? --   See 'lamBrackets'. data ParenPreference = PreferParen | PreferParenless-  deriving (Eq, Ord, Show, Data)+  deriving (Eq, Ord, Show, Data, Generic) +instance NFData ParenPreference+ preferParen :: ParenPreference -> Bool preferParen p = PreferParen == p @@ -51,7 +49,9 @@                 | LeftOperandCtx Fixity | RightOperandCtx Fixity ParenPreference                 | FunctionCtx | ArgumentCtx ParenPreference | InsideOperandCtx                 | WithFunCtx | WithArgCtx | DotPatternCtx-    deriving (Show, Data, Eq)+    deriving (Show, Data, Eq, Generic)++instance NFData Precedence  instance Pretty Precedence where   pretty = text . show

src/full/Agda/Syntax/IdiomBrackets.hs view

@@ -12,12 +12,14 @@ import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad +import Agda.Utils.List1  ( List1, pattern (:|), (<|) ) import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Singleton  parseIdiomBracketsSeq :: Range -> [Expr] -> ScopeM Expr parseIdiomBracketsSeq r es = do-  let qEmpty = QName $ Name noRange InScope [Id "empty"]-      qPlus  = QName $ Name noRange InScope [Hole, Id "<|>", Hole]+  let qEmpty = QName $ simpleName "empty"+      qPlus  = QName $ simpleBinaryOperator "<|>"       ePlus a b = App r (App r (Ident qPlus) (defaultNamedArg a)) (defaultNamedArg b)   case es of     []       -> ensureInScope qEmpty >> return (Ident qEmpty)@@ -29,23 +31,22 @@  parseIdiomBrackets :: Range -> Expr -> ScopeM Expr parseIdiomBrackets r e = do-  let qPure = QName $ Name noRange InScope [Id "pure"]-      qAp   = QName $ Name noRange InScope [Hole, Id "<*>", Hole]+  let qPure = QName $ simpleName "pure"+      qAp   = QName $ simpleBinaryOperator "<*>"       ePure   = App r (Ident qPure) . defaultNamedArg       eAp a b = App r (App r (Ident qAp) (defaultNamedArg a)) (defaultNamedArg b)   mapM_ ensureInScope [qPure, qAp]   case e of     RawApp _ es -> do-      e : es <- appViewM =<< parseApplication es+      e :| es <- appViewM =<< parseApplication es       return $ foldl eAp (ePure e) es     _ -> return $ ePure e -appViewM :: Expr -> ScopeM [Expr]-appViewM e =-  case e of-    App{}           -> let AppView e' es = appView e in (e' :) <$> mapM onlyVisible es-    OpApp _ op _ es -> (Ident op :) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es-    _               -> return [e]+appViewM :: Expr -> ScopeM (List1 Expr)+appViewM = \case+    e@App{}         -> let AppView e' es = appView e in (e' :|) <$> mapM onlyVisible es+    OpApp _ op _ es -> (Ident op :|) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es+    e               -> return $ singleton e   where     onlyVisible a       | defaultNamedArg () == fmap (() <$) a = return $ namedArg a

src/full/Agda/Syntax/Info.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-| 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 +9,13 @@  import Prelude hiding (null) +import Control.DeepSeq+ import Data.Data (Data)+import Data.Semigroup (Semigroup) +import GHC.Generics (Generic)+ import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Common import Agda.Syntax.Position@@ -20,7 +23,6 @@ import Agda.Syntax.Fixity import Agda.Syntax.Scope.Base (ScopeInfo, emptyScopeInfo) -import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Null @@ -34,7 +36,7 @@   , metaNumber         :: Maybe MetaId   , metaNameSuggestion :: String   }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  emptyMetaInfo :: MetaInfo emptyMetaInfo = MetaInfo@@ -50,12 +52,14 @@ instance KillRange MetaInfo where   killRange m = m { metaRange = noRange } +instance NFData MetaInfo+ {--------------------------------------------------------------------------     General expression information  --------------------------------------------------------------------------}  newtype ExprInfo = ExprRange Range-  deriving (Data, Show, Eq, Null)+  deriving (Data, Show, Eq, Null, NFData)  exprNoRange :: ExprInfo exprNoRange = ExprRange noRange@@ -74,9 +78,9 @@ data AppInfo = AppInfo   { appRange  :: Range   , appOrigin :: Origin-  , appParens :: ParenPreference -- ^ Do we prefer a appbda argument with or without parens?+  , appParens :: ParenPreference -- ^ Do we prefer a lambda argument with or without parens?   }-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  -- | Default is system inserted and prefer parens. defaultAppInfo :: Range -> AppInfo@@ -96,6 +100,8 @@   getOrigin = appOrigin   mapOrigin f i = i { appOrigin = f (appOrigin i) } +instance NFData AppInfo+ {--------------------------------------------------------------------------     Module information  --------------------------------------------------------------------------}@@ -111,7 +117,7 @@   , minfoDirective :: Maybe ImportDirective     -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'.   }-  deriving (Data, Eq, Show)+  deriving (Data, Eq, Show, Generic)  instance HasRange ModuleInfo where   getRange = minfoRange@@ -122,12 +128,14 @@ instance KillRange ModuleInfo where   killRange m = m { minfoRange = noRange } +instance NFData ModuleInfo+ --------------------------------------------------------------------------- -- Let info ---------------------------------------------------------------------------  newtype LetInfo = LetRange Range-  deriving (Data, Show, Eq, Null)+  deriving (Data, Show, Eq, Null, NFData)  instance HasRange LetInfo where   getRange (LetRange r)   = r@@ -148,7 +156,7 @@   , defInfo     :: DeclInfo   , defTactic   :: Maybe t   }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  mkDefInfo :: Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t mkDefInfo x f a ab r = mkDefInfoInstance x f a ab NotInstanceDef NotMacroDef r@@ -173,6 +181,7 @@ instance AnyIsAbstract (DefInfo' t) where   anyIsAbstract = defAbstract +instance NFData t => NFData (DefInfo' t)  {--------------------------------------------------------------------------     General declaration information@@ -182,7 +191,7 @@   { declName  :: Name   , declRange :: Range   }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  instance HasRange DeclInfo where   getRange = declRange@@ -193,6 +202,8 @@ instance KillRange DeclInfo where   killRange i = i { declRange = noRange } +instance NFData DeclInfo+ {--------------------------------------------------------------------------     Mutual block information  --------------------------------------------------------------------------}@@ -203,7 +214,7 @@   , mutualPositivityCheck  :: PositivityCheck   , mutualRange            :: Range   }-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  -- | Default value for 'MutualInfo'. instance Null MutualInfo where@@ -215,6 +226,8 @@ instance KillRange MutualInfo where   killRange i = i { mutualRange = noRange } +instance NFData MutualInfo+ {--------------------------------------------------------------------------     Left hand side information  --------------------------------------------------------------------------}@@ -222,7 +235,7 @@ data LHSInfo = LHSInfo   { lhsRange    :: Range   , lhsEllipsis :: ExpandedEllipsis-  } deriving (Data, Show, Eq)+  } deriving (Data, Show, Eq, Generic)  instance HasRange LHSInfo where   getRange (LHSInfo r _) = r@@ -234,6 +247,8 @@   null i = null (lhsRange i) && null (lhsEllipsis i)   empty  = LHSInfo empty empty +instance NFData LHSInfo+ {--------------------------------------------------------------------------     Pattern information  --------------------------------------------------------------------------}@@ -241,7 +256,8 @@ -- | For a general pattern we remember the source code position. newtype PatInfo   = PatRange Range-  deriving (Data, Eq, Null, Show, SetRange, HasRange, KillRange)+  deriving (Data, Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange,+            KillRange, NFData)  -- | Empty range for patterns. patNoRange :: PatInfo@@ -255,7 +271,7 @@   , conPatInfo     :: PatInfo   , conPatLazy     :: ConPatLazy   }-  deriving (Data, Eq, Show)+  deriving (Data, Eq, Show, Generic)  instance HasRange ConPatInfo where   getRange = getRange . conPatInfo@@ -266,8 +282,12 @@ instance SetRange ConPatInfo where   setRange r (ConPatInfo b i l) = ConPatInfo b (PatRange r) l +instance NFData ConPatInfo+ -- | Has the constructor pattern a dotted (forced) constructor? data ConPatLazy   = ConPatLazy   -- ^ Dotted constructor.   | ConPatEager  -- ^ Ordinary constructor.-  deriving (Data, Eq, Ord, Show, Bounded, Enum)+  deriving (Data, Eq, Ord, Show, Bounded, Enum, Generic)++instance NFData ConPatLazy

src/full/Agda/Syntax/Internal.hs view

@@ -1,38 +1,46 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE UndecidableInstances       #-}  -- because of shortcomings of FunctionalDependencies  module Agda.Syntax.Internal     ( module Agda.Syntax.Internal+    , module Agda.Syntax.Internal.Blockers+    , module Agda.Syntax.Internal.Elim     , module Agda.Syntax.Abstract.Name-    , MetaId(..)+    , MetaId(..), ProblemId(..)     ) where -import Prelude hiding (foldr, mapM, null)-import GHC.Stack (HasCallStack, freezeCallStack, callStack)+import Prelude hiding (null) -import Control.Monad.Identity hiding (mapM)+import Control.Monad.Identity import Control.DeepSeq -import Data.Foldable ( Foldable, foldMap ) import Data.Function import qualified Data.List as List import Data.Maybe-import Data.Monoid ( Monoid, mempty, mappend ) import Data.Semigroup ( Semigroup, (<>), Sum(..) )+import qualified Data.Set as Set+import Data.Set (Set)  import Data.Traversable import Data.Data (Data) +import GHC.Generics (Generic)+ import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Literal import Agda.Syntax.Concrete.Pretty (prettyHiding) import Agda.Syntax.Abstract.Name+import Agda.Syntax.Internal.Blockers+import Agda.Syntax.Internal.Elim +import Agda.Utils.CallStack+    ( CallStack+    , HasCallStack+    , prettyCallSite+    , headCallSite+    , withCallerCallStack+    )+ import Agda.Utils.Empty  import Agda.Utils.Functor@@ -83,10 +91,11 @@  -- | Ignores 'Origin' and 'FreeVariables' and tactic. instance Eq a => Eq (Dom' t a) where-  Dom (ArgInfo h1 m1 _ _) b1 s1 _ x1 == Dom (ArgInfo h2 m2 _ _) b2 s2 _ x2 =-    (h1, m1, b1, s1, x1) == (h2, m2, b2, s2, x2)+  Dom (ArgInfo h1 m1 _ _ a1) b1 s1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) b2 s2 _ x2 =+    (h1, m1, a1, b1, s1, x1) == (h2, m2, a2, b2, s2, x2) -instance LensNamed NamedName (Dom' t e) where+instance LensNamed (Dom' t e) where+  type NameOf (Dom' t e) = NamedName   lensNamed f dom = f (domName dom) <&> \ nm -> dom { domName = nm }  instance LensArgInfo (Dom' t e) where@@ -100,6 +109,7 @@ instance LensModality      (Dom' t e) where instance LensOrigin        (Dom' t e) where instance LensFreeVariables (Dom' t e) where+instance LensAnnotation    (Dom' t e) where  -- Since we have LensModality, we get relevance and quantity by default @@ -138,17 +148,22 @@ type Args       = [Arg Term] type NamedArgs  = [NamedArg Term] +data DataOrRecord+  = IsData+  | IsRecord PatternOrCopattern+  deriving (Data, Show, Eq, Generic)+ -- | Store the names of the record fields in the constructor. --   This allows reduction of projection redexes outside of TCM. --   For instance, during substitution and application. data ConHead = ConHead-  { conName      :: QName     -- ^ The name of the constructor.-  , conInductive :: Induction -- ^ Record constructors can be coinductive.-  , conFields    :: [Arg QName]   -- ^ The name of the record fields.-      --   Empty list for data constructors.+  { conName       :: QName         -- ^ The name of the constructor.+  , conDataRecord :: DataOrRecord  -- ^ Data or record constructor?+  , conInductive  :: Induction     -- ^ Record constructors can be coinductive.+  , conFields     :: [Arg QName]   -- ^ The name of the record fields.       --   'Arg' is stored since the info in the constructor args       --   might not be accurate because of subtyping (issue #2170).-  } deriving (Data, Show)+  } deriving (Data, Show, Generic)  instance Eq ConHead where   (==) = (==) `on` conName@@ -211,28 +226,9 @@  type ConInfo = ConOrigin --- | Eliminations, subsuming applications and projections.----data Elim' a-  = Apply (Arg a)         -- ^ Application.-  | Proj ProjOrigin QName -- ^ Projection.  'QName' is name of a record projection.-  | IApply a a a -- ^ IApply x y r, x and y are the endpoints-  deriving (Data, Show, Functor, Foldable, Traversable)- type Elim = Elim' Term type Elims = [Elim]  -- ^ eliminations ordered left-to-right. --- | This instance cheats on 'Proj', use with care.---   'Proj's are always assumed to be 'UserWritten', since they have no 'ArgInfo'.---   Same for IApply-instance LensOrigin (Elim' a) where-  getOrigin (Apply a)   = getOrigin a-  getOrigin Proj{}      = UserWritten-  getOrigin IApply{}    = UserWritten-  mapOrigin f (Apply a) = Apply $ mapOrigin f a-  mapOrigin f e@Proj{}  = e-  mapOrigin f e@IApply{} = e- -- | Binder. -- --   'Abs': The bound variable might appear in the body.@@ -243,7 +239,7 @@                -- ^ The body has (at least) one free variable.                --   Danger: 'unAbs' doesn't shift variables properly            | NoAbs { absName :: ArgName, unAbs :: a }-  deriving (Data, Functor, Foldable, Traversable)+  deriving (Data, Functor, Foldable, Traversable, Generic)  instance Decoration Abs where   traverseF f (Abs   x a) = Abs   x <$> f a@@ -266,6 +262,9 @@   getSort  :: a -> Sort   getSort a = a ^. lensSort +instance LensSort Sort where+  lensSort f s = f s <&> \ s' -> s'+ instance LensSort (Type' a) where   lensSort f (El s a) = f s <&> \ s' -> El s' a @@ -282,18 +281,23 @@ --   and so on. data Tele a = EmptyTel             | ExtendTel a (Abs (Tele a))  -- ^ 'Abs' is never 'NoAbs'.-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Data, Show, Functor, Foldable, Traversable, Generic)  type Telescope = Tele (Dom Type) +data IsFibrant = IsFibrant | IsStrict+  deriving (Data, Show, Eq, Ord, Generic)+ -- | Sorts. -- data Sort' t   = Type (Level' t)  -- ^ @Set ℓ@.   | Prop (Level' t)  -- ^ @Prop ℓ@.-  | Inf         -- ^ @Setω@.+  | Inf IsFibrant Integer      -- ^ @Setωᵢ@.+  | SSet (Level' t)  -- ^ @SSet ℓ@.   | SizeUniv    -- ^ @SizeUniv@, a sort inhabited by type @Size@.-  | PiSort (Dom' t (Type'' t t)) (Abs (Sort' t)) -- ^ Sort of the pi type.+  | LockUniv    -- ^ @LockUniv@, a sort for locks.+  | 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.   | MetaS {-# UNPACK #-} !MetaId [Elim' t]@@ -310,28 +314,15 @@ -- | A level is a maximum expression of a closed level and 0..n --   'PlusLevel' expressions each of which is an atom plus a number. data Level' t = Max Integer [PlusLevel' t]-  deriving (Show, Data)+  deriving (Show, Data, Functor, Foldable, Traversable)  type Level = Level' Term -data PlusLevel' t = Plus Integer (LevelAtom' t)  -- ^ @n + ℓ@.-  deriving (Show, Data)+data PlusLevel' t = Plus Integer t+  deriving (Show, Data, Functor, Foldable, Traversable)  type PlusLevel = PlusLevel' Term---- | An atomic term of type @Level@.-data LevelAtom' t-  = MetaLevel MetaId [Elim' t]-    -- ^ A meta variable targeting @Level@ under some eliminations.-  | BlockedLevel MetaId t-    -- ^ A term of type @Level@ whose reduction is blocked by a meta.-  | NeutralLevel NotBlocked t-    -- ^ A neutral term of type @Level@.-  | UnreducedLevel t-    -- ^ Introduced by 'instantiate', removed by 'reduce'.-  deriving (Show, Data)--type LevelAtom = LevelAtom' Term+type LevelAtom = Term  --------------------------------------------------------------------------- -- * Brave Terms@@ -345,109 +336,11 @@ -- * Blocked Terms --------------------------------------------------------------------------- --- | Even if we are not stuck on a meta during reduction---   we can fail to reduce a definition by pattern matching---   for another reason.-data NotBlocked-  = StuckOn Elim-    -- ^ The 'Elim' is neutral and blocks a pattern match.-  | Underapplied-    -- ^ Not enough arguments were supplied to complete the matching.-  | AbsurdMatch-    -- ^ We matched an absurd clause, results in a neutral 'Def'.-  | MissingClauses-    -- ^ We ran out of clauses, all considered clauses-    --   produced an actual mismatch.-    --   This can happen when try to reduce a function application-    --   but we are still missing some function clauses.-    --   See "Agda.TypeChecking.Patterns.Match".-  | ReallyNotBlocked-    -- ^ Reduction was not blocked, we reached a whnf-    --   which can be anything but a stuck @'Def'@.-  deriving (Show, Data)---- | 'ReallyNotBlocked' is the unit.---   'MissingClauses' is dominant.---   @'StuckOn'{}@ should be propagated, if tied, we take the left.-instance Semigroup NotBlocked where-  ReallyNotBlocked <> b = b-  -- MissingClauses is dominant (absorptive)-  b@MissingClauses <> _ = b-  _ <> b@MissingClauses = b-  -- StuckOn is second strongest-  b@StuckOn{}      <> _ = b-  _ <> b@StuckOn{}      = b-  b <> _                = b--instance Monoid NotBlocked where-  -- ReallyNotBlocked is neutral-  mempty  = ReallyNotBlocked-  mappend = (<>)---- | Something where a meta variable may block reduction.-data Blocked t-  = Blocked    { theBlockingMeta :: MetaId    , ignoreBlocking :: t }-  | NotBlocked { blockingStatus  :: NotBlocked, ignoreBlocking :: t }-  deriving (Data, Show, Functor, Foldable, Traversable)-  -- deriving (Eq, Ord, Functor, Foldable, Traversable)---- | Blocking by a meta is dominant.-instance Applicative Blocked where-  pure = notBlocked-  f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)---- -- | Blocking by a meta is dominant.--- instance Applicative Blocked where---   pure = notBlocked---   Blocked x f     <*> e                = Blocked x $ f (ignoreBlocking e)---   NotBlocked nb f <*> Blocked    x   e = Blocked x $ f e---   NotBlocked nb f <*> NotBlocked nb' e = NotBlocked (nb `mappend` nb') $ f e---- | @'Blocked' t@ without the @t@.-type Blocked_ = Blocked ()--instance Semigroup Blocked_ where-  b@Blocked{}    <> _              = b-  _              <> b@Blocked{}    = b-  NotBlocked x _ <> NotBlocked y _ = NotBlocked (x <> y) ()--instance Monoid Blocked_ where-  mempty = notBlocked ()-  mappend = (<>)---- | When trying to reduce @f es@, on match failed on one---   elimination @e ∈ es@ that came with info @r :: NotBlocked@.---   @stuckOn e r@ produces the new @NotBlocked@ info.------   'MissingClauses' must be propagated, as this is blockage---   that can be lifted in the future (as more clauses are added).------   @'StuckOn' e0@ is also propagated, since it provides more---   precise information as @StuckOn e@ (as @e0@ is the original---   reason why reduction got stuck and usually a subterm of @e@).---   An information like @StuckOn (Apply (Arg info (Var i [])))@---   (stuck on a variable) could be used by the lhs/coverage checker---   to trigger a split on that (pattern) variable.------   In the remaining cases for @r@, we are terminally stuck---   due to @StuckOn e@.  Propagating @'AbsurdMatch'@ does not---   seem useful.+type Blocked    = Blocked' Term+type NotBlocked = NotBlocked' Term -----   'Underapplied' must not be propagated, as this would mean---   that @f es@ is underapplied, which is not the case (it is stuck).---   Note that 'Underapplied' can only arise when projection patterns were---   missing to complete the original match (in @e@).---   (Missing ordinary pattern would mean the @e@ is of function type,---   but we cannot match against something of function type.)-stuckOn :: Elim -> NotBlocked -> NotBlocked-stuckOn e r =-  case r of-    MissingClauses   -> r-    StuckOn{}        -> r-    Underapplied     -> r'-    AbsurdMatch      -> r'-    ReallyNotBlocked -> r'-  where r' = StuckOn e+-- | @'Blocked a@ without the @a@.+type Blocked_ = Blocked ()  --------------------------------------------------------------------------- -- * Definitions@@ -486,6 +379,12 @@       --   pattern on the lhs.     , clauseCatchall  :: Bool       -- ^ Clause has been labelled as CATCHALL.+    , clauseExact       :: Maybe Bool+      -- ^ Pattern matching of this clause is exact, no catch-all case.+      --   Computed by the coverage checker.+      --   @Nothing@ means coverage checker has not run yet (clause may be inexact).+      --   @Just False@ means clause is not exact.+      --   @Just True@ means clause is exact.     , clauseRecursive   :: Maybe Bool       -- ^ @clauseBody@ contains recursive calls; computed by termination checker.       --   @Nothing@ means that termination checker has not run yet,@@ -501,7 +400,7 @@     , clauseEllipsis  :: ExpandedEllipsis       -- ^ Was this clause created by expansion of an ellipsis?     }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  clausePats :: Clause -> [Arg DeBruijnPattern] clausePats = map (fmap namedThing) . namedClausePats@@ -521,7 +420,7 @@ data PatternInfo = PatternInfo   { patOrigin :: PatOrigin   , patAsNames :: [Name]-  } deriving (Data, Show, Eq)+  } deriving (Data, Show, Eq, Generic)  defaultPatternInfo :: PatternInfo defaultPatternInfo = PatternInfo PatOSystem []@@ -537,7 +436,7 @@   | PatORec            -- ^ User wrote a record pattern   | PatOLit            -- ^ User wrote a literal pattern   | PatOAbsurd         -- ^ User wrote an absurd pattern-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  -- | Patterns are variables, constructors, or wildcards. --   @QName@ is used in @ConP@ rather than @Name@ since@@ -561,7 +460,7 @@     -- ^ Path elimination pattern, like @VarP@ but keeps track of endpoints.   | DefP PatternInfo QName [NamedArg (Pattern' x)]     -- ^ Used for HITs, the QName should be the one from primHComp.-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Data, Show, Functor, Foldable, Traversable, Generic)  type Pattern = Pattern' PatVarName     -- ^ The @PatVarName@ is a name suggestion.@@ -579,7 +478,7 @@ data DBPatVar = DBPatVar   { dbPatVarName  :: PatVarName   , dbPatVarIndex :: Int-  } deriving (Data, Show, Eq)+  } deriving (Data, Show, Eq, Generic)  type DeBruijnPattern = Pattern' DBPatVar @@ -626,7 +525,7 @@     --   variables they bind are unused. The GHC backend compiles lazy matches     --   to lazy patterns in Haskell (TODO: not yet).   }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  noConPatternInfo :: ConPatternInfo noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False@@ -638,9 +537,7 @@  -- | Build 'ConInfo' from 'ConPatternInfo'. fromConPatternInfo :: ConPatternInfo -> ConInfo-fromConPatternInfo i-  | conPRecord i = patToConO $ patOrigin $ conPInfo i-  | otherwise    = ConOCon+fromConPatternInfo i = patToConO $ patOrigin $ conPInfo i   where     patToConO :: PatOrigin -> ConOrigin     patToConO = \case@@ -651,15 +548,18 @@       PatOWild   -> ConOSystem       PatOCon    -> ConOCon       PatORec    -> ConORec-      PatOLit    -> __IMPOSSIBLE__+      PatOLit    -> ConOCon       PatOAbsurd -> ConOSystem  -- | Extract pattern variables in left-to-right order. --   A 'DotP' is also treated as variable (see docu for 'Clause').-class PatternVars a b | b -> a where-  patternVars :: b -> [Arg (Either a Term)]+class PatternVars a where+  type PatternVarOut a+  patternVars :: a -> [Arg (Either (PatternVarOut a) Term)] -instance PatternVars a (Arg (Pattern' a)) where+instance PatternVars (Arg (Pattern' a)) where+  type PatternVarOut (Arg (Pattern' a)) = a+   -- patternVars :: Arg (Pattern' a) -> [Arg (Either a Term)]   patternVars (Arg i (VarP _ x)   ) = [Arg i $ Left x]   patternVars (Arg i (DotP _ t)   ) = [Arg i $ Right t]@@ -670,10 +570,14 @@   patternVars (Arg i (IApplyP _ _ _ x)) = [Arg i $ Left x]  -instance PatternVars a (NamedArg (Pattern' a)) where+instance PatternVars (NamedArg (Pattern' a)) where+  type PatternVarOut (NamedArg (Pattern' a)) = a+   patternVars = patternVars . fmap namedThing -instance PatternVars a b => PatternVars a [b] where+instance PatternVars a => PatternVars [a] where+  type PatternVarOut [a] = PatternVarOut a+   patternVars = concatMap patternVars  -- | Retrieve the PatternInfo from a pattern@@ -728,7 +632,7 @@     -- ^ Identity substitution.     --   @Γ ⊢ IdS : Γ@ -  | EmptyS Empty+  | EmptyS Impossible     -- ^ Empty substitution, lifts from the empty context. First argument is @__IMPOSSIBLE__@.     --   Apply this to closed terms you want to use in a non-empty context.     --   @Γ ⊢ EmptyS : ()@@@ -741,7 +645,7 @@     --     Γ ⊢ u :# ρ : Δ, A     --   @ -  | Strengthen Empty (Substitution' a)+  | Strengthen Impossible (Substitution' a)     -- ^ Strengthening substitution.  First argument is @__IMPOSSIBLE__@.     --   Apply this to a term which does not contain variable 0     --   to lower all de Bruijn indices by one.@@ -773,7 +677,7 @@            , Functor            , Foldable            , Traversable-           , Data+           , Generic            )  type Substitution = Substitution' Term@@ -803,10 +707,12 @@     , eqtRhs   :: Arg Term -- ^ NotHidden     }   | OtherType Type -- ^ reduced+  | IdiomType Type -- ^ reduced  isEqualityType :: EqualityView -> Bool isEqualityType EqualityType{} = True isEqualityType OtherType{}    = False+isEqualityType IdiomType{}    = False  -- | View type as path type. @@ -873,77 +779,72 @@     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.-dummyTerm' :: String -> Int -> Term-dummyTerm' file line = flip Dummy [] $ file ++ ":" ++ show line+dummyTermWith :: DummyTermKind -> CallStack -> Term+dummyTermWith kind cs = flip Dummy [] $ concat [kind, ": ", dummyLocName cs] --- | Aux: A dummy level to constitute a level/sort.-dummyLevel' :: String -> Int -> Level-dummyLevel' file line = unreducedLevel $ dummyTerm' file line+-- | A dummy level to constitute a level/sort created at location.+--   Note: use macro __DUMMY_LEVEL__ !+dummyLevel :: CallStack -> Level+dummyLevel = atomicLevel . dummyTermWith "dummyLevel"  -- | A dummy term created at location. --   Note: use macro __DUMMY_TERM__ !-dummyTerm :: String -> Int -> Term-dummyTerm file = dummyTerm' ("dummyTerm: " ++ file)+dummyTerm :: CallStack -> Term+dummyTerm = dummyTermWith "dummyTerm"  __DUMMY_TERM__ :: HasCallStack => Term-__DUMMY_TERM__ = withFileAndLine' (freezeCallStack callStack) dummyTerm---- | A dummy level created at location.---   Note: use macro __DUMMY_LEVEL__ !-dummyLevel :: String -> Int -> Level-dummyLevel file = dummyLevel' ("dummyLevel: " ++ file)+__DUMMY_TERM__ = withCallerCallStack dummyTerm  __DUMMY_LEVEL__ :: HasCallStack => Level-__DUMMY_LEVEL__ = withFileAndLine' (freezeCallStack callStack) dummyLevel+__DUMMY_LEVEL__ = withCallerCallStack dummyLevel  -- | A dummy sort created at location. --   Note: use macro __DUMMY_SORT__ !-dummySort :: String -> Int -> Sort-dummySort file line = DummyS $ file ++ ":" ++ show line+dummySort :: CallStack -> Sort+dummySort = DummyS . dummyLocName  __DUMMY_SORT__ :: HasCallStack => Sort-__DUMMY_SORT__ = withFileAndLine' (freezeCallStack callStack) dummySort+__DUMMY_SORT__ = withCallerCallStack dummySort  -- | A dummy type created at location. --   Note: use macro __DUMMY_TYPE__ !-dummyType :: String -> Int -> Type-dummyType file line = El (dummySort file line) $ dummyTerm' ("dummyType: " ++ file) line+dummyType :: CallStack -> Type+dummyType cs = El (dummySort cs) $ dummyTermWith "dummyType" cs  __DUMMY_TYPE__ :: HasCallStack => Type-__DUMMY_TYPE__ = withFileAndLine' (freezeCallStack callStack) dummyType+__DUMMY_TYPE__ = withCallerCallStack dummyType  -- | Context entries without a type have this dummy type. --   Note: use macro __DUMMY_DOM__ !-dummyDom :: String -> Int -> Dom Type-dummyDom file line = defaultDom $ dummyType file line+dummyDom :: CallStack -> Dom Type+dummyDom = defaultDom . dummyType  __DUMMY_DOM__ :: HasCallStack => Dom Type-__DUMMY_DOM__ = withFileAndLine' (freezeCallStack callStack) dummyDom+__DUMMY_DOM__ = withCallerCallStack dummyDom  -- | Constant level @n@ pattern ClosedLevel :: Integer -> Level pattern ClosedLevel n = Max n [] -atomicLevel :: LevelAtom -> Level+atomicLevel :: t -> Level' t atomicLevel a = Max 0 [ Plus 0 a ] -unreducedLevel :: Term -> Level-unreducedLevel v = atomicLevel $ UnreducedLevel v---- | Top sort (Set\omega).-topSort :: Type-topSort = sort Inf--sort :: Sort -> Type-sort s = El (UnivSort s) $ Sort s- varSort :: Int -> Sort-varSort n = Type $ atomicLevel $ NeutralLevel mempty $ var n+varSort n = Type $ atomicLevel $ var n  tmSort :: Term -> Sort-tmSort t = Type $ unreducedLevel t+tmSort t = Type $ atomicLevel t +tmSSort :: Term -> Sort+tmSSort t = SSet $ atomicLevel t+ -- | 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@@ -958,16 +859,16 @@ mkProp :: Integer -> Sort mkProp n = Prop $ ClosedLevel n +mkSSet :: Integer -> Sort+mkSSet n = SSet $ ClosedLevel n+ isSort :: Term -> Maybe Sort-isSort v = case v of+isSort = \case   Sort s -> Just s   _      -> Nothing -impossibleTerm :: String -> Int -> Term-impossibleTerm file line = flip Dummy [] $ unlines-  [ "An internal error has occurred. Please report this as a bug."-  , "Location of the error: " ++ file ++ ":" ++ show line-  ]+impossibleTerm :: CallStack -> Term+impossibleTerm = flip Dummy [] . show . Impossible  --------------------------------------------------------------------------- -- * Telescopes.@@ -1042,34 +943,14 @@   sgTel dom = sgTel (stringToArgName "_", dom)  ------------------------------------------------------------------------------ * Handling blocked terms.------------------------------------------------------------------------------blockingMeta :: Blocked t -> Maybe MetaId-blockingMeta (Blocked m _) = Just m-blockingMeta NotBlocked{}  = Nothing--blocked :: MetaId -> a -> Blocked a-blocked = Blocked--notBlocked :: a -> Blocked a-notBlocked = NotBlocked ReallyNotBlocked--blocked_ :: MetaId -> Blocked_-blocked_ x = blocked x ()--notBlocked_ :: Blocked_-notBlocked_ = notBlocked ()----------------------------------------------------------------------------- -- * Simple operations on terms and types. ---------------------------------------------------------------------------  -- | Removing a topmost 'DontCare' constructor. stripDontCare :: Term -> Term-stripDontCare v = case v of+stripDontCare = \case   DontCare v -> v-  _          -> v+  v          -> v  -- | Doesn't do any reduction. arity :: Type -> Nat@@ -1139,7 +1020,7 @@     Con{}      -> Nothing     Lit{}      -> Nothing     -- Andreas, 2016-04-13, Issue 1932: We convert λ x → x .f  into f-    Lam _ (Abs _ v)  -> case v of+    Lam h (Abs _ v) | visible h -> case v of       Var 0 [Proj _o f] -> Just (Def f, [])       _ -> Nothing     Lam{}      -> Nothing@@ -1149,40 +1030,6 @@     DontCare{} -> Nothing     Dummy{}    -> Nothing --- | 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' :: Empty -> Elim' a -> Arg a-isApplyElim' e = fromMaybe (absurd e) . isApplyElim---- | Drop 'Apply' constructors. (Safe)-allApplyElims :: [Elim' a] -> Maybe [Arg a]-allApplyElims = mapM isApplyElim---- | Split at first non-'Apply'-splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])-splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es-splitApplyElims es             = ([], es)--class IsProjElim e where-  isProjElim  :: e -> Maybe (ProjOrigin, QName)--instance IsProjElim (Elim' a) where-  isProjElim (Proj o d) = Just (o, d)-  isProjElim Apply{}    = Nothing-  isProjElim IApply{} = Nothing---- | Discards @Proj f@ entries.-argsFromElims :: Elims -> Args-argsFromElims = mapMaybe isApplyElim---- | Drop 'Proj' constructors. (Safe)-allProjElims :: Elims -> Maybe [(ProjOrigin, QName)]-allProjElims = mapM isProjElim- --------------------------------------------------------------------------- -- * Null instances. ---------------------------------------------------------------------------@@ -1195,8 +1042,8 @@ -- | A 'null' clause is one with no patterns and no rhs. --   Should not exist in practice. instance Null Clause where-  empty = Clause empty empty empty empty empty empty False Nothing Nothing empty-  null (Clause _ _ tel pats body _ _ _ _ _)+  empty = Clause empty empty empty empty empty empty False Nothing Nothing Nothing empty+  null (Clause _ _ tel pats body _ _ _ _ _ _)     =  null tel     && null pats     && null body@@ -1249,7 +1096,7 @@   tsize = foldMap tsize  instance TermSize Term where-  tsize v = case v of+  tsize = \case     Var _ vs    -> 1 + tsize vs     Def _ vs    -> 1 + tsize vs     Con _ _ vs    -> 1 + tsize vs@@ -1263,12 +1110,14 @@     Dummy{}     -> 1  instance TermSize Sort where-  tsize s = case s of+  tsize = \case     Type l    -> 1 + tsize l     Prop l    -> 1 + tsize l-    Inf       -> 1+    Inf _ _   -> 1+    SSet l    -> 1 + tsize l     SizeUniv  -> 1-    PiSort a s -> 1 + tsize a + tsize s+    LockUniv  -> 1+    PiSort a s1 s2 -> 1 + tsize a + tsize s1 + tsize s2     FunSort s1 s2 -> 1 + tsize s1 + tsize s2     UnivSort s -> 1 + tsize s     MetaS _ es -> 1 + tsize es@@ -1281,12 +1130,6 @@ instance TermSize PlusLevel where   tsize (Plus _ a)      = tsize a -instance TermSize LevelAtom where-  tsize (MetaLevel _   vs) = 1 + tsize vs-  tsize (BlockedLevel _ v) = tsize v-  tsize (NeutralLevel _ v) = tsize v-  tsize (UnreducedLevel v) = tsize v- instance TermSize a => TermSize (Substitution' a) where   tsize IdS                = 1   tsize (EmptyS _)         = 1@@ -1299,11 +1142,14 @@ -- * KillRange instances. --------------------------------------------------------------------------- +instance KillRange DataOrRecord where+  killRange = id+ instance KillRange ConHead where-  killRange (ConHead c i fs) = killRange3 ConHead c i fs+  killRange (ConHead c d i fs) = killRange4 ConHead c d i fs  instance KillRange Term where-  killRange v = case v of+  killRange = \case     Var i vs    -> killRange1 (Var i) vs     Def c vs    -> killRange2 Def c vs     Con c ci vs -> killRange3 Con c ci vs@@ -1314,7 +1160,7 @@     Pi a b      -> killRange2 Pi a b     Sort s      -> killRange1 Sort s     DontCare mv -> killRange1 DontCare mv-    Dummy{}     -> v+    v@Dummy{}   -> v  instance KillRange Level where   killRange (Max n as) = killRange1 (Max n) as@@ -1322,27 +1168,23 @@ instance KillRange PlusLevel where   killRange (Plus n l) = killRange1 (Plus n) l -instance KillRange LevelAtom where-  killRange (MetaLevel n as)   = killRange1 (MetaLevel n) as-  killRange (BlockedLevel m v) = killRange1 (BlockedLevel m) v-  killRange (NeutralLevel r v) = killRange1 (NeutralLevel r) v-  killRange (UnreducedLevel v) = killRange1 UnreducedLevel v- instance (KillRange a) => KillRange (Type' a) where   killRange (El s v) = killRange2 El s v  instance KillRange Sort where-  killRange s = case s of-    Inf        -> Inf+  killRange = \case+    Inf f n    -> Inf f n     SizeUniv   -> SizeUniv+    LockUniv   -> LockUniv     Type a     -> killRange1 Type a     Prop a     -> killRange1 Prop a-    PiSort a s -> killRange2 PiSort a s+    SSet a     -> killRange1 SSet a+    PiSort a s1 s2 -> killRange3 PiSort a s1 s2     FunSort s1 s2 -> killRange2 FunSort s1 s2     UnivSort s -> killRange1 UnivSort s     MetaS x es -> killRange1 (MetaS x) es     DefS d es  -> killRange2 DefS d es-    DummyS{}   -> s+    s@DummyS{} -> s  instance KillRange Substitution where   killRange IdS                  = IdS@@ -1376,8 +1218,8 @@       DefP o q ps      -> killRange2 (DefP o) q ps  instance KillRange Clause where-  killRange (Clause rl rf tel ps body t catchall recursive unreachable ell) =-    killRange10 Clause rl rf tel ps body t catchall recursive unreachable ell+  killRange (Clause rl rf tel ps body t catchall exact recursive unreachable ell) =+    killRange10 Clause rl rf tel ps body t catchall exact recursive unreachable ell  instance KillRange a => KillRange (Tele a) where   killRange = fmap killRange@@ -1388,9 +1230,6 @@ instance KillRange a => KillRange (Abs a) where   killRange = fmap killRange -instance KillRange a => KillRange (Elim' a) where-  killRange = fmap killRange- ----------------------------------------------------------------------------- -- * Simple pretty printing -----------------------------------------------------------------------------@@ -1432,6 +1271,10 @@       pApp d els = mparens (not (null els) && p > 9) $                    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 e) => Pretty (Dom' t e) where   pretty dom = pTac <+> pDom dom (pretty $ unDom dom)     where@@ -1478,14 +1321,6 @@ instance Pretty PlusLevel where   prettyPrec p (Plus n a) = prettyPrecLevelSucs p n $ \p -> prettyPrec p a -instance Pretty LevelAtom where-  prettyPrec p a =-    case a of-      MetaLevel x els  -> prettyPrec p (MetaV x els)-      BlockedLevel _ v -> prettyPrec p v-      NeutralLevel _ v -> prettyPrec p v-      UnreducedLevel v -> prettyPrec p v- instance Pretty Sort where   prettyPrec p s =     case s of@@ -1495,27 +1330,28 @@       Prop (ClosedLevel 0) -> "Prop"       Prop (ClosedLevel n) -> text $ "Prop" ++ show n       Prop l -> mparens (p > 9) $ "Prop" <+> prettyPrec 10 l-      Inf -> "Setω"+      Inf f 0 -> text $ addS f "Setω"+      Inf f n -> text $ addS f "Setω" ++ show n+      SSet l -> mparens (p > 9) $ "SSet" <+> prettyPrec 10 l       SizeUniv -> "SizeUniv"-      PiSort a b -> mparens (p > 9) $-        "piSort" <+> pDom (domInfo a) (text (absName b) <+> ":" <+> pretty (unDom a))-                      <+> parens (sep [ text ("λ " ++ absName b ++ " ->")-                                      , nest 2 $ pretty (unAbs b) ])+      LockUniv -> "LockUniv"+      PiSort a s1 s2 -> mparens (p > 9) $+        "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a))+                      <+> parens (sep [ text ("λ " ++ absName s2 ++ " ->")+                                      , nest 2 $ pretty (unAbs s2) ])       FunSort a b -> mparens (p > 9) $         "funSort" <+> prettyPrec 10 a <+> prettyPrec 10 b       UnivSort s -> mparens (p > 9) $ "univSort" <+> prettyPrec 10 s       MetaS x es -> prettyPrec p $ MetaV x es       DefS d es  -> prettyPrec p $ Def d es       DummyS s   -> parens $ text s+   where+     addS IsFibrant t = t+     addS IsStrict  t = "S" ++ t  instance Pretty Type where   prettyPrec p (El _ a) = prettyPrec p a -instance Pretty tm => Pretty (Elim' tm) where-  prettyPrec p (Apply v)    = prettyPrec p v-  prettyPrec _ (Proj _o x)  = text ("." ++ prettyShow x)-  prettyPrec p (IApply x y r) = prettyPrec p r- instance Pretty DBPatVar where   prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x) @@ -1539,6 +1375,8 @@   prettyPrec _ (LitP _ l)    = pretty l   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+ ----------------------------------------------------------------------------- -- * NFData instances -----------------------------------------------------------------------------@@ -1546,7 +1384,7 @@ -- Note: only strict in the shape of the terms.  instance NFData Term where-  rnf v = case v of+  rnf = \case     Var _ es   -> rnf es     Lam _ b    -> rnf (unAbs b)     Lit l      -> rnf l@@ -1563,12 +1401,14 @@   rnf (El s v) = rnf (s, v)  instance NFData Sort where-  rnf s = case s of+  rnf = \case     Type l   -> rnf l     Prop l   -> rnf l-    Inf      -> ()+    Inf _ _  -> ()+    SSet l   -> rnf l     SizeUniv -> ()-    PiSort a b -> rnf (a, unAbs b)+    LockUniv -> ()+    PiSort a b c -> rnf (a, b, unAbs c)     FunSort a b -> rnf (a, b)     UnivSort a -> rnf a     MetaS _ es -> rnf es@@ -1581,16 +1421,18 @@ instance NFData PlusLevel where   rnf (Plus n l) = rnf (n, l) -instance NFData LevelAtom where-  rnf (MetaLevel _ es)   = rnf es-  rnf (BlockedLevel _ v) = rnf v-  rnf (NeutralLevel _ v) = rnf v-  rnf (UnreducedLevel v) = rnf v--instance NFData a => NFData (Elim' a) where-  rnf (Apply x) = rnf x-  rnf Proj{}    = ()-  rnf (IApply x y r) = rnf x `seq` rnf y `seq` rnf r- instance NFData e => NFData (Dom e) where   rnf (Dom a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e++instance NFData DataOrRecord+instance NFData ConHead+instance NFData a => NFData (Abs a)+instance NFData a => NFData (Tele a)+instance NFData IsFibrant+instance NFData Clause+instance NFData PatternInfo+instance NFData PatOrigin+instance NFData x => NFData (Pattern' x)+instance NFData DBPatVar+instance NFData ConPatternInfo+instance NFData a => NFData (Substitution' a)

+ src/full/Agda/Syntax/Internal/Blockers.hs view

@@ -0,0 +1,271 @@++module Agda.Syntax.Internal.Blockers where++import Control.DeepSeq++import Data.Data (Data)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Semigroup++import GHC.Generics (Generic)++import Agda.Syntax.Common+import Agda.Syntax.Internal.Elim++import Agda.Utils.Pretty hiding ((<>))+import Agda.Utils.Functor++---------------------------------------------------------------------------+-- * Blocked Terms+---------------------------------------------------------------------------++-- | Even if we are not stuck on a meta during reduction+--   we can fail to reduce a definition by pattern matching+--   for another reason.+data NotBlocked' t+  = StuckOn (Elim' t)+    -- ^ The 'Elim' is neutral and blocks a pattern match.+  | Underapplied+    -- ^ Not enough arguments were supplied to complete the matching.+  | AbsurdMatch+    -- ^ We matched an absurd clause, results in a neutral 'Def'.+  | MissingClauses+    -- ^ We ran out of clauses, all considered clauses+    --   produced an actual mismatch.+    --   This can happen when try to reduce a function application+    --   but we are still missing some function clauses.+    --   See "Agda.TypeChecking.Patterns.Match".+  | ReallyNotBlocked+    -- ^ Reduction was not blocked, we reached a whnf+    --   which can be anything but a stuck @'Def'@.+  deriving (Show, Data, Generic)++-- | 'ReallyNotBlocked' is the unit.+--   'MissingClauses' is dominant.+--   @'StuckOn'{}@ should be propagated, if tied, we take the left.+instance Semigroup (NotBlocked' t) where+  ReallyNotBlocked <> b = b+  -- MissingClauses is dominant (absorptive)+  b@MissingClauses <> _ = b+  _ <> b@MissingClauses = b+  -- StuckOn is second strongest+  b@StuckOn{}      <> _ = b+  _ <> b@StuckOn{}      = b+  b <> _                = b++instance Monoid (NotBlocked' t) where+  -- ReallyNotBlocked is neutral+  mempty  = ReallyNotBlocked+  mappend = (<>)++instance NFData t => NFData (NotBlocked' t)++-- | 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+  deriving (Data, Show, Eq, Ord, Generic)++instance NFData Blocker++alwaysUnblock :: Blocker+alwaysUnblock = UnblockOnAll Set.empty++neverUnblock :: Blocker+neverUnblock = UnblockOnAny Set.empty++unblockOnAll :: Set Blocker -> Blocker+unblockOnAll us =+  case allViewS us of+    us | [u] <- Set.toList us -> u+    us                        -> UnblockOnAll us+  where+    allViewS = Set.unions . map allView . Set.toList+    allView (UnblockOnAll us) = allViewS us+    allView u                 = Set.singleton u++unblockOnAny :: Set Blocker -> Blocker+unblockOnAny us =+  case anyViewS us of+    us | [u] <- Set.toList us        -> u+    us | Set.member alwaysUnblock us -> alwaysUnblock+       | otherwise                   -> UnblockOnAny us+  where+    anyViewS = Set.unions . map anyView . Set.toList+    anyView (UnblockOnAny us) = anyViewS us+    anyView u                 = Set.singleton u++unblockOnEither :: Blocker -> Blocker -> Blocker+unblockOnEither a b = unblockOnAny $ Set.fromList [a, b]++unblockOnMeta :: MetaId -> Blocker+unblockOnMeta = UnblockOnMeta++unblockOnProblem :: ProblemId -> Blocker+unblockOnProblem = UnblockOnProblem++unblockOnAllMetas :: Set MetaId -> Blocker+unblockOnAllMetas = unblockOnAll . Set.mapMonotonic unblockOnMeta++unblockOnAnyMeta :: Set MetaId -> Blocker+unblockOnAnyMeta = unblockOnAny . Set.mapMonotonic unblockOnMeta++onBlockingMetasM :: Monad m => (MetaId -> m Blocker) -> Blocker -> m Blocker+onBlockingMetasM f (UnblockOnAll bs)    = unblockOnAll . Set.fromList <$> mapM (onBlockingMetasM f) (Set.toList bs)+onBlockingMetasM f (UnblockOnAny bs)    = unblockOnAny . Set.fromList <$> mapM (onBlockingMetasM f) (Set.toList bs)+onBlockingMetasM f (UnblockOnMeta x)    = f x+onBlockingMetasM f b@UnblockOnProblem{} = pure b++allBlockingMetas :: Blocker -> Set MetaId+allBlockingMetas (UnblockOnAll us)  = Set.unions $ map allBlockingMetas $ Set.toList us+allBlockingMetas (UnblockOnAny us)  = Set.unions $ map allBlockingMetas $ Set.toList us+allBlockingMetas (UnblockOnMeta x)  = Set.singleton x+allBlockingMetas UnblockOnProblem{} = Set.empty++allBlockingProblems :: Blocker -> Set ProblemId+allBlockingProblems (UnblockOnAll us)    = Set.unions $ map allBlockingProblems $ Set.toList us+allBlockingProblems (UnblockOnAny us)    = Set.unions $ map allBlockingProblems $ Set.toList us+allBlockingProblems UnblockOnMeta{}      = Set.empty+allBlockingProblems (UnblockOnProblem p) = Set.singleton p++-- Note: We pick the All rather than the Any as the semigroup instance.+instance Semigroup Blocker where+  x <> y = unblockOnAll $ Set.fromList [x, y]++instance Monoid Blocker where+  mempty = alwaysUnblock+  mappend = (<>)++instance Pretty Blocker where+  pretty (UnblockOnAll us)      = "all" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us)+  pretty (UnblockOnAny us)      = "any" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us)+  pretty (UnblockOnMeta m)      = pretty m+  pretty (UnblockOnProblem pid) = "problem" <+> pretty pid++-- | Something where a meta variable may block reduction. Notably a top-level meta is considered+--   blocking. This did not use to be the case (pre Aug 2020).+data Blocked' t a+  = Blocked    { theBlocker      :: Blocker,       ignoreBlocking :: a }+  | NotBlocked { blockingStatus  :: NotBlocked' t, ignoreBlocking :: a }+  deriving (Data, Show, Functor, Foldable, Traversable, Generic)++instance Decoration (Blocked' t) where+  traverseF f (Blocked b x)     = Blocked b <$> f x+  traverseF f (NotBlocked nb x) = NotBlocked nb <$> f x++-- | Blocking on _all_ blockers.+instance Applicative (Blocked' t) where+  pure = notBlocked+  f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)++instance Semigroup a => Semigroup (Blocked' t a) where+  Blocked x a    <> Blocked y b    = Blocked (x <> y) (a <> b)+  b@Blocked{}    <> NotBlocked{}   = b+  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+  mempty = notBlocked mempty+  mappend = (<>)++instance (NFData t, NFData a) => NFData (Blocked' t a)++-- | When trying to reduce @f es@, on match failed on one+--   elimination @e ∈ es@ that came with info @r :: NotBlocked@.+--   @stuckOn e r@ produces the new @NotBlocked@ info.+--+--   'MissingClauses' must be propagated, as this is blockage+--   that can be lifted in the future (as more clauses are added).+--+--   @'StuckOn' e0@ is also propagated, since it provides more+--   precise information as @StuckOn e@ (as @e0@ is the original+--   reason why reduction got stuck and usually a subterm of @e@).+--   An information like @StuckOn (Apply (Arg info (Var i [])))@+--   (stuck on a variable) could be used by the lhs/coverage checker+--   to trigger a split on that (pattern) variable.+--+--   In the remaining cases for @r@, we are terminally stuck+--   due to @StuckOn e@.  Propagating @'AbsurdMatch'@ does not+--   seem useful.+--+--   'Underapplied' must not be propagated, as this would mean+--   that @f es@ is underapplied, which is not the case (it is stuck).+--   Note that 'Underapplied' can only arise when projection patterns were+--   missing to complete the original match (in @e@).+--   (Missing ordinary pattern would mean the @e@ is of function type,+--   but we cannot match against something of function type.)+stuckOn :: Elim' t -> NotBlocked' t -> NotBlocked' t+stuckOn e r =+  case r of+    MissingClauses   -> r+    StuckOn{}        -> r+    Underapplied     -> r'+    AbsurdMatch      -> r'+    ReallyNotBlocked -> r'+  where r' = StuckOn e++---------------------------------------------------------------------------+-- * Handling blocked terms.+---------------------------------------------------------------------------++blockedOn :: Blocker -> a -> Blocked' t a+blockedOn b | alwaysUnblock == b = notBlocked+            | otherwise          = Blocked b++blocked :: MetaId -> a -> Blocked' t a+blocked = Blocked . unblockOnMeta++notBlocked :: a -> Blocked' t a+notBlocked = NotBlocked ReallyNotBlocked++blocked_ :: MetaId -> Blocked' t ()+blocked_ x = blocked x ()++notBlocked_ :: Blocked' t ()+notBlocked_ = notBlocked ()++-----------------------------------------------------------------------------+-- * Waking up logic+-----------------------------------------------------------------------------++-- | Should a constraint wake up or not? If not, we might refine the unblocker.+data WakeUp = WakeUp | DontWakeUp (Maybe Blocker)+  deriving (Show, Eq)++wakeUpWhen :: (constr -> Bool) -> (constr -> WakeUp) -> constr -> WakeUp+wakeUpWhen guard wake c | guard c   = wake c+                        | otherwise = DontWakeUp Nothing++wakeUpWhen_ :: (constr -> Bool) -> constr -> WakeUp+wakeUpWhen_ p = wakeUpWhen p (const WakeUp)++wakeIfBlockedOnProblem :: ProblemId -> Blocker -> WakeUp+wakeIfBlockedOnProblem pid u+  | u' == alwaysUnblock = WakeUp+  | otherwise           = DontWakeUp (Just u')+  where+    u' = unblockProblem pid u++wakeIfBlockedOnMeta :: MetaId -> Blocker -> WakeUp+wakeIfBlockedOnMeta x u+  | u' == alwaysUnblock = WakeUp+  | otherwise           = DontWakeUp (Just u')+  where+    u' = unblockMeta x u++unblockMeta :: MetaId -> Blocker -> Blocker+unblockMeta x u@(UnblockOnMeta y) | x == y    = alwaysUnblock+                                  | otherwise = u+unblockMeta _ u@UnblockOnProblem{} = u+unblockMeta x (UnblockOnAll us)    = unblockOnAll $ Set.map (unblockMeta x) us+unblockMeta x (UnblockOnAny us)    = unblockOnAny $ Set.map (unblockMeta x) us++unblockProblem :: ProblemId -> Blocker -> Blocker+unblockProblem p u@(UnblockOnProblem q) | p == q    = alwaysUnblock+                                        | otherwise = u+unblockProblem _ u@UnblockOnMeta{} = u+unblockProblem p (UnblockOnAll us) = unblockOnAll $ Set.map (unblockProblem p) us+unblockProblem p (UnblockOnAny us) = unblockOnAny $ Set.map (unblockProblem p) us

src/full/Agda/Syntax/Internal/Defs.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-}  -- | Extract used definitions from terms. @@ -7,7 +6,6 @@ import Control.Monad.Reader import Control.Monad.Writer -import Data.Foldable (Foldable) import qualified Data.Foldable as Fold  import Agda.Syntax.Common@@ -56,7 +54,7 @@   getDefs = getDefs . clauseBody  instance GetDefs Term where-  getDefs v = case v of+  getDefs = \case     Def d vs   -> doDef d >> getDefs vs     Con _ _ vs -> getDefs vs     Lit l      -> return ()@@ -76,12 +74,14 @@   getDefs (El s t) = getDefs s >> getDefs t  instance GetDefs Sort where-  getDefs s = case s of+  getDefs = \case     Type l    -> getDefs l     Prop l    -> getDefs l-    Inf       -> return ()+    Inf _ _   -> return ()+    SSet l    -> getDefs l     SizeUniv  -> return ()-    PiSort a s  -> getDefs a >> getDefs s+    LockUniv  -> 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@@ -93,13 +93,6 @@  instance GetDefs PlusLevel where   getDefs (Plus _ l)    = getDefs l--instance GetDefs LevelAtom where-  getDefs a = case a of-    MetaLevel x vs   -> getDefs x >> getDefs vs-    BlockedLevel _ v -> getDefs v-    NeutralLevel _ v -> getDefs v-    UnreducedLevel v -> getDefs v  -- collection instances

+ src/full/Agda/Syntax/Internal/Elim.hs view

@@ -0,0 +1,83 @@++module Agda.Syntax.Internal.Elim where++import Control.DeepSeq+import Data.Data (Data)++import Agda.Syntax.Common+import Agda.Syntax.Concrete.Pretty () -- Pretty Arg instance+import Agda.Syntax.Position+import Agda.Syntax.Abstract.Name++import Agda.Utils.Pretty+import Agda.Utils.Empty+import Agda.Utils.Maybe+import Agda.Utils.Tuple++-- | Eliminations, subsuming applications and projections.+--+data Elim' a+  = Apply (Arg a)         -- ^ Application.+  | Proj ProjOrigin QName -- ^ Projection.  'QName' is name of a record projection.+  | IApply a a a -- ^ IApply x y r, x and y are the endpoints+  deriving (Data, Show, Functor, Foldable, Traversable)++-- | This instance cheats on 'Proj', use with care.+--   'Proj's are always assumed to be 'UserWritten', since they have no 'ArgInfo'.+--   Same for IApply+instance LensOrigin (Elim' a) where+  getOrigin (Apply a)   = getOrigin a+  getOrigin Proj{}      = UserWritten+  getOrigin IApply{}    = UserWritten+  mapOrigin f (Apply a) = Apply $ mapOrigin f a+  mapOrigin f e@Proj{}  = e+  mapOrigin f e@IApply{} = e++-- | 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' :: Empty -> Elim' a -> Arg a+isApplyElim' e = fromMaybe (absurd e) . isApplyElim++-- | Drop 'Apply' constructors. (Safe)+allApplyElims :: [Elim' a] -> Maybe [Arg a]+allApplyElims = mapM isApplyElim++-- | Split at first non-'Apply'+splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])+splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es+splitApplyElims es             = ([], es)++class IsProjElim e where+  isProjElim  :: e -> Maybe (ProjOrigin, QName)++instance IsProjElim (Elim' a) where+  isProjElim (Proj o d) = Just (o, d)+  isProjElim Apply{}    = Nothing+  isProjElim IApply{} = Nothing++-- | Discards @Proj f@ entries.+argsFromElims :: [Elim' t] -> [Arg t]+argsFromElims = mapMaybe isApplyElim++-- | Drop 'Proj' constructors. (Safe)+allProjElims :: [Elim' t] -> Maybe [(ProjOrigin, QName)]+allProjElims = mapM isProjElim++instance KillRange a => KillRange (Elim' a) where+  killRange = fmap killRange++instance Pretty tm => Pretty (Elim' tm) where+  prettyPrec p (Apply v)    = prettyPrec p v+  prettyPrec _ (Proj _o x)  = text ("." ++ prettyShow x)+  prettyPrec p (IApply x y r) = prettyPrec p r+--  prettyPrec p (IApply x y r) = text "@[" <> prettyPrec 0 x <> text ", " <> prettyPrec 0 y <> text "]" <> prettyPrec p r++instance NFData a => NFData (Elim' a) where+  rnf (Apply x) = rnf x+  rnf Proj{}    = ()+  rnf (IApply x y r) = rnf x `seq` rnf y `seq` rnf r+

src/full/Agda/Syntax/Internal/Generic.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP          #-}  -- | Tree traversal for internal syntax.@@ -10,6 +9,7 @@ #endif import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Utils.Functor  -- | Generic term traversal. --@@ -24,7 +24,6 @@    default traverseTermM :: (Monad m, Traversable f, TermLike b, f b ~ a)                         => (Term -> m Term) -> a -> m a-   traverseTermM = traverse . traverseTermM    -- | Generic fold, ignoring sorts.@@ -63,8 +62,8 @@ instance TermLike a => TermLike (Dom a)        where instance TermLike a => TermLike [a]            where instance TermLike a => TermLike (Maybe a)      where-instance TermLike a => TermLike (Abs a)        where instance TermLike a => TermLike (Blocked a)    where+instance TermLike a => TermLike (Abs a)        where instance TermLike a => TermLike (Tele a)       where instance TermLike a => TermLike (WithHiding a) where @@ -86,7 +85,7 @@  instance TermLike Term where -  traverseTermM f t = case t of+  traverseTermM f = \case     Var i xs    -> f =<< Var i <$> traverseTermM f xs     Def c xs    -> f =<< Def c <$> traverseTermM f xs     Con c ci xs -> f =<< Con c ci <$> traverseTermM f xs@@ -94,10 +93,10 @@     Pi a b      -> f =<< uncurry Pi <$> traverseTermM f (a, b)     MetaV m xs  -> f =<< MetaV m <$> traverseTermM f xs     Level l     -> f =<< Level <$> traverseTermM f l-    Lit _       -> f t+    t@Lit{}     -> f t     Sort s      -> f =<< Sort <$> traverseTermM f s     DontCare mv -> f =<< DontCare <$> traverseTermM f mv-    Dummy{}     -> f t+    t@Dummy{}   -> f t    foldTerm f t = f t `mappend` case t of     Var i xs    -> foldTerm f xs@@ -120,41 +119,33 @@   traverseTermM f (Plus n l) = Plus n <$> traverseTermM f l   foldTerm f (Plus _ l)      = foldTerm f l -instance TermLike LevelAtom where-  traverseTermM f l = case l of-    MetaLevel m vs   -> MetaLevel m <$> traverseTermM f vs-    NeutralLevel r v -> NeutralLevel r <$> traverseTermM f v-    BlockedLevel m v -> BlockedLevel m <$> traverseTermM f v-    UnreducedLevel v -> UnreducedLevel <$> traverseTermM f v-  foldTerm f l = case l of-    MetaLevel m vs   -> foldTerm f vs-    NeutralLevel _ v -> foldTerm f v-    BlockedLevel _ v -> foldTerm f v-    UnreducedLevel v -> foldTerm f v- instance TermLike Type where   traverseTermM f (El s t) = El s <$> traverseTermM f t   foldTerm f (El s t) = foldTerm f t  instance TermLike Sort where-  traverseTermM f s = case s of+  traverseTermM f = \case     Type l     -> Type <$> traverseTermM f l     Prop l     -> Prop <$> traverseTermM f l-    Inf        -> pure s-    SizeUniv   -> pure s-    PiSort a b -> PiSort   <$> traverseTermM f a <*> traverseTermM f b+    s@(Inf _ _)-> pure s+    SSet l     -> SSet <$> traverseTermM f l+    s@SizeUniv -> pure s+    s@LockUniv -> pure s+    PiSort a b c -> PiSort   <$> traverseTermM f a <*> traverseTermM f b <*> traverseTermM f c     FunSort a b -> FunSort   <$> traverseTermM f a <*> traverseTermM f b     UnivSort a -> UnivSort <$> traverseTermM f a     MetaS x es -> MetaS x  <$> traverseTermM f es     DefS q es  -> DefS q   <$> traverseTermM f es-    DummyS{}   -> pure s+    s@DummyS{} -> pure s -  foldTerm f s = case s of+  foldTerm f = \case     Type l     -> foldTerm f l     Prop l     -> foldTerm f l-    Inf        -> mempty+    Inf _ _    -> mempty+    SSet l     -> foldTerm f l     SizeUniv   -> mempty-    PiSort a b -> foldTerm f a <> foldTerm f b+    LockUniv   -> mempty+    PiSort a b c -> foldTerm f a <> foldTerm f b <> foldTerm f c     FunSort a b -> foldTerm f a <> foldTerm f b     UnivSort a -> foldTerm f a     MetaS _ es -> foldTerm f es@@ -163,17 +154,20 @@  instance TermLike EqualityView where -  traverseTermM f v = case v of+  traverseTermM f = \case     OtherType t -> OtherType       <$> traverseTermM f t+    IdiomType t -> IdiomType+      <$> traverseTermM f t     EqualityType s eq l t a b -> EqualityType s eq       <$> traverse (traverseTermM f) l       <*> traverseTermM f t       <*> traverseTermM f a       <*> traverseTermM f b -  foldTerm f v = case v of+  foldTerm f = \case     OtherType t -> foldTerm f t+    IdiomType t -> foldTerm f t     EqualityType s eq l t a b -> foldTerm f (l ++ [t, a, b])  -- | Put it in a monad to make it possible to do strictly.

src/full/Agda/Syntax/Internal/MetaVars.hs view

@@ -2,6 +2,7 @@ module Agda.Syntax.Internal.MetaVars where  import Data.Monoid+import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -10,20 +11,58 @@ import Agda.Utils.Singleton  -- | Returns every meta-variable occurrence in the given type, except--- for those in 'Sort's.-allMetas :: (TermLike a, Monoid m) => (MetaId -> m) -> a -> m-allMetas singl = foldTerm metas+-- for those in sort annotations on types.+class AllMetas t where+  allMetas :: Monoid m => (MetaId -> m) -> t -> m++  default allMetas :: (TermLike t, Monoid m) => (MetaId -> m) -> t -> m+  allMetas = allMetas'++-- Default instances+instance AllMetas Term+instance AllMetas Type+instance TermLike a => AllMetas (Elim' a)+instance TermLike a => AllMetas (Tele a)+instance TermLike a => AllMetas (Dom a)++-- 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])++-- Generic instances+instance (AllMetas a, AllMetas b) => AllMetas (a, b) where+  allMetas f (x, y) = allMetas f x <> allMetas f y++instance (AllMetas a, AllMetas b, AllMetas c) => AllMetas (a, b, c) where+  allMetas f (x, y, z) = allMetas f (x, (y, z))++instance (AllMetas a, AllMetas b, AllMetas c, AllMetas d) => AllMetas (a, b, c, d) where+  allMetas f (x, y, z, w) = allMetas f (x, (y, (z, w)))++instance AllMetas a => AllMetas [a]       where allMetas f xs = foldMap (allMetas f) xs+instance AllMetas a => AllMetas (Maybe a) where allMetas f xs = foldMap (allMetas f) xs+instance AllMetas a => AllMetas (Arg a)   where allMetas f xs = foldMap (allMetas f) xs++allMetas' :: (TermLike a, Monoid m) => (MetaId -> m) -> a -> m+allMetas' singl = foldTerm metas   where   metas (MetaV m _) = singl m-  metas (Level l)   = levelMetas l+  metas (Sort s)    = sortMetas s   metas _           = mempty -  levelMetas (Max _ as) = foldMap plusLevelMetas as--  plusLevelMetas (Plus _ l)    = levelAtomMetas l--  levelAtomMetas (MetaLevel m _) = singl m-  levelAtomMetas _               = mempty+  sortMetas Type{}        = mempty+  sortMetas Prop{}        = mempty+  sortMetas SSet{}        = mempty+  sortMetas Inf{}         = mempty+  sortMetas SizeUniv{}    = mempty+  sortMetas LockUniv{}    = mempty+  sortMetas (PiSort _ s1 s2)  = sortMetas s1 <> sortMetas (unAbs s2)  -- the domain is a term so is covered by the fold+  sortMetas (FunSort a b) = sortMetas a <> sortMetas b+  sortMetas (UnivSort s)  = sortMetas s+  sortMetas (MetaS x _)   = singl x+  sortMetas DefS{}        = mempty+  sortMetas DummyS{}      = mempty  -- | Returns 'allMetas' in a list. --   @allMetasList = allMetas (:[])@.@@ -31,15 +70,23 @@ --   Note: this resulting list is computed via difference lists. --   Thus, use this function if you actually need the whole list of metas. --   Otherwise, use 'allMetas' with a suitable monoid.-allMetasList :: TermLike a => a -> [MetaId]+allMetasList :: AllMetas a => a -> [MetaId] allMetasList t = allMetas singleton t `appEndo` []  -- | 'True' if thing contains no metas. --   @noMetas = null . allMetasList@.-noMetas :: TermLike a => a -> Bool+noMetas :: AllMetas a => a -> Bool noMetas = getAll . allMetas (\ _m -> All False)  -- | Returns the first meta it find in the thing, if any. --   @firstMeta == listToMaybe . allMetasList@.-firstMeta :: TermLike a => a -> Maybe MetaId+firstMeta :: AllMetas a => a -> Maybe MetaId firstMeta = getFirst . allMetas (First . Just)++-- | A blocker that unblocks if any of the metas in a term are solved.+unblockOnAnyMetaIn :: AllMetas t => t -> Blocker+unblockOnAnyMetaIn t = unblockOnAnyMeta $ allMetas Set.singleton t++-- | A blocker that unblocks if any of the metas in a term are solved.+unblockOnAllMetasIn :: AllMetas t => t -> Blocker+unblockOnAllMetasIn t = unblockOnAllMetas $ allMetas Set.singleton t

src/full/Agda/Syntax/Internal/Names.hs view

@@ -1,14 +1,11 @@-{-# LANGUAGE TypeFamilies #-}  -- | Extract all names from things.  module Agda.Syntax.Internal.Names where  import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Map as Map+import Data.Map (Map) import Data.Set (Set)-import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Literal@@ -19,38 +16,59 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.CompiledClause -+import Agda.Utils.Singleton import Agda.Utils.Impossible +namesIn :: (NamesIn a, Collection QName m) => a -> m+namesIn = namesIn' singleton+ class NamesIn a where-  namesIn :: a -> Set QName+  namesIn' :: Monoid m => (QName -> m) -> a -> m -  default namesIn :: (Foldable f, NamesIn b, f b ~ a) => a -> Set QName-  namesIn = foldMap namesIn+  default namesIn' :: (Monoid m, Foldable f, NamesIn b, f b ~ a) => (QName -> m) -> a -> m+  namesIn' = foldMap . namesIn' -instance NamesIn a => NamesIn (Maybe a)              where-instance NamesIn a => NamesIn [a]                    where-instance NamesIn a => NamesIn (NonEmpty a)           where-instance NamesIn a => NamesIn (Arg a)                where-instance NamesIn a => NamesIn (Dom a)                where-instance NamesIn a => NamesIn (Named n a)            where-instance NamesIn a => NamesIn (Abs a)                where-instance NamesIn a => NamesIn (WithArity a)          where-instance NamesIn a => NamesIn (Tele a)               where-instance NamesIn a => NamesIn (C.FieldAssignment' a) where+-- Generic collections+instance NamesIn a => NamesIn (Maybe a)+instance NamesIn a => NamesIn [a]+instance NamesIn a => NamesIn (NonEmpty a)+instance NamesIn a => NamesIn (Set a)+instance NamesIn a => NamesIn (Map k a) +-- Decorations+instance NamesIn a => NamesIn (Arg a)+instance NamesIn a => NamesIn (Dom a)+instance NamesIn a => NamesIn (Named n a)+instance NamesIn a => NamesIn (Abs a)+instance NamesIn a => NamesIn (WithArity a)+instance NamesIn a => NamesIn (Open a)+instance NamesIn a => NamesIn (C.FieldAssignment' a)++-- Specific collections+instance NamesIn a => NamesIn (Tele a)++-- Tuples+ instance (NamesIn a, NamesIn b) => NamesIn (a, b) where-  namesIn (x, y) = Set.union (namesIn x) (namesIn y)+  namesIn' sg (x, y) = mappend (namesIn' sg x) (namesIn' sg y)  instance (NamesIn a, NamesIn b, NamesIn c) => NamesIn (a, b, c) where-  namesIn (x, y, z) = namesIn (x, (y, z))+  namesIn' sg (x, y, z) = namesIn' sg (x, (y, z))  instance (NamesIn a, NamesIn b, NamesIn c, NamesIn d) => NamesIn (a, b, c, d) where-  namesIn (x, y, z, u) = namesIn ((x, y), (z, u))+  namesIn' sg (x, y, z, u) = namesIn' sg ((x, y), (z, u))  instance NamesIn CompKit where-  namesIn (CompKit a b) = namesIn (a,b)+  namesIn' sg (CompKit a b) = namesIn' sg (a,b) +-- Base case++instance NamesIn QName where+  namesIn' sg x = sg x  -- interesting case!++instance NamesIn ConHead where+  namesIn' sg h = namesIn' sg (conName h)+ -- Andreas, 2017-07-27 -- In the following clauses, the choice of fields is not obvious -- to the reader.  Please comment on the choices.@@ -60,143 +78,140 @@ -- If someone adds a field containing names, this would go unnoticed.  instance NamesIn Definition where-  namesIn def = namesIn (defType def, theDef def, defDisplay def)+  namesIn' sg def = namesIn' sg (defType def, theDef def, defDisplay def)  instance NamesIn Defn where-  namesIn def = case def of-    Axiom -> Set.empty-    DataOrRecSig{} -> Set.empty-    GeneralizableVar{} -> Set.empty+  namesIn' sg = \case+    Axiom _            -> mempty+    DataOrRecSig{}     -> mempty+    GeneralizableVar{} -> mempty+    PrimitiveSort{}    -> mempty+    AbstractDefn{}     -> __IMPOSSIBLE__     -- Andreas 2017-07-27, Q: which names can be in @cc@ which are not already in @cl@?-    Function    { funClauses = cl, funCompiled = cc }              -> namesIn (cl, cc)-    Datatype    { dataClause = cl, dataCons = cs, dataSort = s }   -> namesIn (cl, cs, s)-    Record      { recClause = cl, recConHead = c, recFields = fs, recComp = comp } -> namesIn (cl, c, fs, comp)+    Function    { funClauses = cl, funCompiled = cc }+      -> namesIn' sg (cl, cc)+    Datatype    { dataClause = cl, dataCons = cs, dataSort = s }+      -> namesIn' sg (cl, cs, s)+    Record      { recClause = cl, recConHead = c, recFields = fs, recComp = comp }+      -> namesIn' sg (cl, c, fs, comp)       -- Don't need recTel since those will be reachable from the constructor-    Constructor { conSrcCon = c, conData = d, conComp = kit, conProj = fs }        -> namesIn (c, d, kit, fs)-    Primitive   { primClauses = cl, primCompiled = cc }            -> namesIn (cl, cc)-    AbstractDefn{} -> __IMPOSSIBLE__+    Constructor { conSrcCon = c, conData = d, conComp = kit, conProj = fs }+      -> namesIn' sg (c, d, kit, fs)+    Primitive   { primClauses = cl, primCompiled = cc }+      -> namesIn' sg (cl, cc)  instance NamesIn Clause where-  namesIn Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =-    namesIn (tel, ps, b, t)+  namesIn' sg Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =+    namesIn' sg (tel, ps, b, t)  instance NamesIn CompiledClauses where-  namesIn (Case _ c) = namesIn c-  namesIn (Done _ v) = namesIn v-  namesIn Fail       = Set.empty+  namesIn' sg (Case _ c) = namesIn' sg c+  namesIn' sg (Done _ v) = namesIn' sg v+  namesIn' sg Fail{}     = mempty  -- Andreas, 2017-07-27 -- Why ignoring the litBranches? instance NamesIn a => NamesIn (Case a) where-  namesIn Branches{ conBranches = bs, catchAllBranch = c } =-    namesIn (Map.toList bs, c)+  namesIn' sg Branches{ conBranches = bs, catchAllBranch = c } =+    namesIn' sg (bs, c)  instance NamesIn (Pattern' a) where-  namesIn p = case p of-    VarP{}        -> Set.empty-    LitP _ l      -> namesIn l-    DotP _ v      -> namesIn v-    ConP c _ args -> namesIn (c, args)-    DefP o q args -> namesIn (q, args)-    ProjP _ f     -> namesIn f-    IApplyP _ t u _ -> namesIn (t, u)+  namesIn' sg = \case+    VarP{}          -> mempty+    LitP _ l        -> namesIn' sg l+    DotP _ v        -> namesIn' sg v+    ConP c _ args   -> namesIn' sg (c, args)+    DefP o q args   -> namesIn' sg (q, args)+    ProjP _ f       -> namesIn' sg f+    IApplyP _ t u _ -> namesIn' sg (t, u)  instance NamesIn a => NamesIn (Type' a) where-  namesIn (El s t) = namesIn (s, t)+  namesIn' sg (El s t) = namesIn' sg (s, t)  instance NamesIn Sort where-  namesIn s = case s of-    Type l   -> namesIn l-    Prop l   -> namesIn l-    Inf      -> Set.empty-    SizeUniv -> Set.empty-    PiSort a b -> namesIn (a, b)-    FunSort a b -> namesIn (a, b)-    UnivSort a -> namesIn a-    MetaS _ es -> namesIn es-    DefS d es  -> namesIn (d, es)-    DummyS{}   -> Set.empty+  namesIn' sg = \case+    Type l      -> namesIn' sg l+    Prop l      -> namesIn' sg l+    Inf _ _     -> mempty+    SSet l      -> namesIn' sg l+    SizeUniv    -> mempty+    LockUniv    -> mempty+    PiSort a b c  -> namesIn' sg (a, b, c)+    FunSort a b -> namesIn' sg (a, b)+    UnivSort a  -> namesIn' sg a+    MetaS _ es  -> namesIn' sg es+    DefS d es   -> namesIn' sg (d, es)+    DummyS{}    -> mempty  instance NamesIn Term where-  namesIn v = case v of-    Var _ args   -> namesIn args-    Lam _ b      -> namesIn b-    Lit l        -> namesIn l-    Def f args   -> namesIn (f, args)-    Con c _ args -> namesIn (c, args)-    Pi a b       -> namesIn (a, b)-    Sort s       -> namesIn s-    Level l      -> namesIn l-    MetaV _ args -> namesIn args-    DontCare v   -> namesIn v-    Dummy{}      -> Set.empty+  namesIn' sg = \case+    Var _ args   -> namesIn' sg args+    Lam _ b      -> namesIn' sg b+    Lit l        -> namesIn' sg l+    Def f args   -> namesIn' sg (f, args)+    Con c _ args -> namesIn' sg (c, args)+    Pi a b       -> namesIn' sg (a, b)+    Sort s       -> namesIn' sg s+    Level l      -> namesIn' sg l+    MetaV _ args -> namesIn' sg args+    DontCare v   -> namesIn' sg v+    Dummy{}      -> mempty  instance NamesIn Level where-  namesIn (Max _ ls) = namesIn ls+  namesIn' sg (Max _ ls) = namesIn' sg ls  instance NamesIn PlusLevel where-  namesIn (Plus _ l) = namesIn l--instance NamesIn LevelAtom where-  namesIn l = case l of-    MetaLevel _ args -> namesIn args-    BlockedLevel _ v -> namesIn v-    NeutralLevel _ v -> namesIn v-    UnreducedLevel v -> namesIn v+  namesIn' sg (Plus _ l) = namesIn' sg l  -- For QName literals! instance NamesIn Literal where-  namesIn l = case l of-    LitNat{}      -> Set.empty-    LitWord64{}   -> Set.empty-    LitString{}   -> Set.empty-    LitChar{}     -> Set.empty-    LitFloat{}    -> Set.empty-    LitQName _  x -> namesIn x-    LitMeta{}     -> Set.empty+  namesIn' sg = \case+    LitNat{}      -> mempty+    LitWord64{}   -> mempty+    LitString{}   -> mempty+    LitChar{}     -> mempty+    LitFloat{}    -> mempty+    LitQName    x -> namesIn' sg x+    LitMeta{}     -> mempty  instance NamesIn a => NamesIn (Elim' a) where-  namesIn (Apply arg) = namesIn arg-  namesIn (Proj _ f)  = namesIn f-  namesIn (IApply x y arg) = namesIn (x, y, arg)--instance NamesIn QName   where namesIn x = Set.singleton x  -- interesting case-instance NamesIn ConHead where namesIn h = namesIn (conName h)--instance NamesIn a => NamesIn (Open a)  where+  namesIn' sg (Apply arg)      = namesIn' sg arg+  namesIn' sg (Proj _ f)       = namesIn' sg f+  namesIn' sg (IApply x y arg) = namesIn' sg (x, y, arg)  instance NamesIn DisplayForm where-  namesIn (Display _ ps v) = namesIn (ps, v)+  namesIn' sg (Display _ ps v) = namesIn' sg (ps, v)  instance NamesIn DisplayTerm where-  namesIn v = case v of-    DWithApp v us es -> namesIn (v, us, es)-    DCon c _ vs      -> namesIn (c, vs)-    DDef f es        -> namesIn (f, es)-    DDot v           -> namesIn v-    DTerm v          -> namesIn v+  namesIn' sg = \case+    DWithApp v us es -> namesIn' sg (v, us, es)+    DCon c _ vs      -> namesIn' sg (c, vs)+    DDef f es        -> namesIn' sg (f, es)+    DDot v           -> namesIn' sg v+    DTerm v          -> namesIn' sg v  -- Pattern synonym stuff --  newtype PSyn = PSyn A.PatternSynDefn instance NamesIn PSyn where-  namesIn (PSyn (_args, p)) = namesIn p+  namesIn' sg (PSyn (_args, p)) = namesIn' sg p  instance NamesIn (A.Pattern' a) where-  namesIn p = case p of-    A.VarP{}               -> Set.empty-    A.ConP _ c args        -> namesIn (c, args)-    A.ProjP _ _ d          -> namesIn d-    A.DefP _ f args        -> namesIn (f, args)-    A.WildP{}              -> Set.empty-    A.AsP _ _ p            -> namesIn p-    A.AbsurdP{}            -> Set.empty-    A.LitP l               -> namesIn l-    A.PatternSynP _ c args -> namesIn (c, args)-    A.RecP _ fs            -> namesIn fs+  namesIn' sg = \case+    A.VarP{}               -> mempty+    A.ConP _ c args        -> namesIn' sg (c, args)+    A.ProjP _ _ d          -> namesIn' sg d+    A.DefP _ f args        -> namesIn' sg (f, args)+    A.WildP{}              -> mempty+    A.AsP _ _ p            -> namesIn' sg p+    A.AbsurdP{}            -> mempty+    A.LitP _ l             -> namesIn' sg l+    A.PatternSynP _ c args -> namesIn' sg (c, args)+    A.RecP _ fs            -> namesIn' sg fs     A.DotP{}               -> __IMPOSSIBLE__    -- Dot patterns are not allowed in pattern synonyms     A.EqualP{}             -> __IMPOSSIBLE__    -- Andrea: should we allow these in pattern synonyms?-    A.WithP _ p            -> namesIn p+    A.WithP _ p            -> namesIn' sg p+    A.AnnP _ a p           -> __IMPOSSIBLE__    -- Type annotations are not (yet) allowed in pattern synonyms  instance NamesIn AmbiguousQName where-  namesIn (AmbQ cs) = namesIn cs+  namesIn' sg (AmbQ cs) = namesIn' sg cs

src/full/Agda/Syntax/Internal/Pattern.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeFamilies           #-}  -- because of type equality ~-{-# LANGUAGE UndecidableInstances   #-}  -- because of func. deps.  module Agda.Syntax.Internal.Pattern where @@ -11,7 +9,6 @@ import qualified Data.List as List  import Agda.Syntax.Common-import Agda.Syntax.Abstract (IsProjP(..)) import Agda.Syntax.Internal  import Agda.Utils.List@@ -56,39 +53,50 @@  -- | Label the pattern variables from left to right --   using one label for each variable pattern and one for each dot pattern.-class LabelPatVars a b i | b -> i where-  labelPatVars :: a -> State [i] b+class LabelPatVars a b where+  type PatVarLabel b+  labelPatVars :: a -> State [PatVarLabel b] b   unlabelPatVars :: b -> a   -- ^ Intended, but unpractical due to the absence of type-level lambda, is:   --   @labelPatVars :: f (Pattern' x) -> State [i] (f (Pattern' (i,x)))@    default labelPatVars-    :: (Traversable f, LabelPatVars a' b' i, f a' ~ a, f b' ~ b)-    => a -> State [i] b+    :: (Traversable f+      , LabelPatVars a' b'+      , PatVarLabel b ~  PatVarLabel b'+      , f a' ~ a, f b' ~ b)+    => a -> State [PatVarLabel b] b   labelPatVars = traverse labelPatVars    default unlabelPatVars-    :: (Traversable f, LabelPatVars a' b' i, f a' ~ a, f b' ~ b)+    :: (Traversable f, LabelPatVars a' b', f a' ~ a, f b' ~ b)     => b -> a   unlabelPatVars = fmap unlabelPatVars -instance LabelPatVars a b i => LabelPatVars (Arg a) (Arg b) i         where-instance LabelPatVars a b i => LabelPatVars (Named x a) (Named x b) i where-instance LabelPatVars a b i => LabelPatVars [a] [b] i                 where+instance LabelPatVars a b => LabelPatVars (Arg a) (Arg b) where+  type PatVarLabel (Arg b) = PatVarLabel b -instance LabelPatVars Pattern DeBruijnPattern Int where-  labelPatVars p =-    case p of-      VarP o x     -> do i <- next-                         return $ VarP o (DBPatVar x i)-      DotP o t     -> DotP o t <$ next-      ConP c mt ps -> ConP c mt <$> labelPatVars ps-      DefP o q ps -> DefP o q <$> labelPatVars ps-      LitP o l     -> return $ LitP o l-      ProjP o q    -> return $ ProjP o q-      IApplyP o u t x -> do i <- next-                            return $ IApplyP o u t (DBPatVar x i)-    where next = caseListM get __IMPOSSIBLE__ $ \ x xs -> do put xs; return x+instance LabelPatVars a b => LabelPatVars (Named x a) (Named x b) where+  type PatVarLabel (Named x b) = PatVarLabel b++instance LabelPatVars a b => LabelPatVars [a] [b] where+  type PatVarLabel [b] = PatVarLabel b++instance LabelPatVars Pattern DeBruijnPattern where+  type PatVarLabel DeBruijnPattern = Int++  labelPatVars = \case+    VarP o x        -> VarP o . DBPatVar x <$> next+    DotP o t        -> DotP o t <$ next+    ConP c mt ps    -> ConP c mt <$> labelPatVars ps+    DefP o q  ps    -> DefP o q <$> labelPatVars ps+    LitP  o l       -> return $ LitP o l+    ProjP o q       -> return $ ProjP o q+    IApplyP o u t x -> IApplyP o u t . DBPatVar x <$> next+   where+    next = caseListM get __IMPOSSIBLE__ $ \x xs -> do+      put xs+      return x   unlabelPatVars = fmap dbPatVarName  -- | Augment pattern variables with their de Bruijn index.@@ -107,11 +115,11 @@ --    dBpats    = 3 .(suc 2) (cons 2 1 0 ) --  @ ---numberPatVars :: LabelPatVars a b Int => Int -> Permutation -> a -> b+numberPatVars :: (LabelPatVars a b, PatVarLabel b ~ Int) => Int -> Permutation -> a -> b numberPatVars err perm ps = evalState (labelPatVars ps) $   permPicks $ flipP $ invertP err perm -unnumberPatVars :: LabelPatVars a b i => b -> a+unnumberPatVars :: LabelPatVars a b => b -> a unnumberPatVars = unlabelPatVars  dbPatPerm :: [NamedArg DeBruijnPattern] -> Maybe Permutation@@ -130,7 +138,7 @@   where     ixs   = concatMap (getIndices . namedThing . unArg) ps     n     = size $ catMaybes ixs-    picks = forM (downFrom n) $ \ i -> List.findIndex (Just i ==) ixs+    picks = forM (downFrom n) $ \ i -> List.elemIndex (Just i) ixs      getIndices :: DeBruijnPattern -> [Maybe Int]     getIndices (VarP _ x)    = [Just $ dbPatVarIndex x]@@ -311,18 +319,22 @@  -- Computing modalities of pattern variables ------------------------------ -class PatternVarModalities p x | p -> x where+class PatternVarModalities p where+  type PatVar p   -- | Get the list of pattern variables annotated with modalities.-  patternVarModalities :: p -> [(x, Modality)]+  patternVarModalities :: p -> [(PatVar p, Modality)] -instance PatternVarModalities a x => PatternVarModalities [a] x where+instance PatternVarModalities a => PatternVarModalities [a] where+  type PatVar [a] = PatVar a   patternVarModalities = foldMap patternVarModalities -instance PatternVarModalities a x => PatternVarModalities (Named s a) x where+instance PatternVarModalities a => PatternVarModalities (Named s a) where+  type PatVar (Named s a) = PatVar a   patternVarModalities = foldMap patternVarModalities -instance PatternVarModalities a x => PatternVarModalities (Arg a) x where-  patternVarModalities arg = map (second (m <>)) (patternVarModalities $ unArg arg)+instance PatternVarModalities a => PatternVarModalities (Arg a) where+  type PatVar (Arg a) = PatVar a+  patternVarModalities arg = map (second (composeModality m)) (patternVarModalities $ unArg arg)     where m = getModality arg  -- UNUSED:@@ -331,7 +343,8 @@ --   patternVarModalities (IApply x y p) = patternVarModalities [x, y, p] --   patternVarModalities Proj{}    = [] -instance PatternVarModalities (Pattern' x) x where+instance PatternVarModalities (Pattern' x) where+  type PatVar (Pattern' x) = x   patternVarModalities p =     case p of       VarP _ x    -> [(x, defaultModality)]

src/full/Agda/Syntax/Internal/SanityCheck.hs view

@@ -8,7 +8,7 @@ import Agda.TypeChecking.Free import Agda.TypeChecking.Monad -import Agda.Utils.List ( dropEnd )+import Agda.Utils.List ( dropEnd, initWithDefault ) import Agda.Utils.Pretty import Agda.Utils.Size import Agda.Utils.Impossible@@ -54,7 +54,7 @@                                                                         , text $ "< " ++ show n ]           sanityCheckSubst (dropLastN n gamma) rho (dropLastN n delta) -    dropLast = telFromList . init . telToList+    dropLast = telFromList . initWithDefault __IMPOSSIBLE__ . telToList     dropLastN n = telFromList . dropEnd n . telToList      err reason = do

src/full/Agda/Syntax/Literal.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}  module Agda.Syntax.Literal where @@ -7,49 +6,40 @@ import Data.Word  import Data.Data (Data)--import Numeric.IEEE ( IEEE(identicalIEEE) )+import Data.Text (Text)+import qualified Data.Text as T  import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Abstract.Name-import Agda.Utils.Pretty import Agda.Utils.FileName--data Literal = LitNat    Range !Integer-             | LitWord64 Range !Word64-             | LitFloat  Range !Double-             | LitString Range String-             | LitChar   Range !Char-             | LitQName  Range QName-             | LitMeta   Range AbsolutePath MetaId-  deriving Data+import Agda.Utils.Float ( doubleDenotEq, doubleDenotOrd )+import Agda.Utils.Pretty -instance Show Literal where-  showsPrec p l = showParen (p > 9) $ case l of-    LitNat _ n    -> sh "LitNat _" n-    LitWord64 _ n -> sh "LitWord64 _" n-    LitFloat _ x  -> sh "LitFloat _" x-    LitString _ s -> sh "LitString _" s-    LitChar _ c   -> sh "LitChar _" c-    LitQName _ q  -> sh "LitQName _" q-    LitMeta _ _ x -> sh "LitMeta _ _" x-    where-      sh :: Show a => String -> a -> ShowS-      sh c x = showString (c ++ " ") . shows x+type RLiteral = Ranged Literal+data Literal+  = LitNat    !Integer+  | LitWord64 !Word64+  | LitFloat  !Double+  | LitString !Text+  | LitChar   !Char+  | LitQName  !QName+  | LitMeta   AbsolutePath MetaId+  deriving (Data, Show)  instance Pretty Literal where-    pretty (LitNat _ n)     = text $ show n-    pretty (LitWord64 _ n)  = text $ show n-    pretty (LitFloat _ d)   = text $ show d-    pretty (LitString _ s)  = text $ showString' s ""-    pretty (LitChar _ c)    = text $ "'" ++ showChar' c "'"-    pretty (LitQName _ x)   = pretty x-    pretty (LitMeta _ _ x)  = pretty x+    pretty (LitNat n)     = pretty n+    pretty (LitWord64 n)  = pretty n+    pretty (LitFloat d)   = pretty d+    pretty (LitString s)  = text $ showText s ""+    pretty (LitChar c)    = text $ "'" ++ showChar' c "'"+    pretty (LitQName x)   = pretty x+    pretty (LitMeta _ x)  = pretty x -showString' :: String -> ShowS-showString' s =-    foldr (.) id $ [ showString "\"" ] ++ map showChar' s ++ [ showString "\"" ]+showText :: Text -> ShowS+showText s = showString "\""+           . T.foldr (\ c -> (showChar' c .)) id s+           . showString "\""  showChar' :: Char -> ShowS showChar' '"'   = showString "\\\""@@ -60,26 +50,26 @@         escapeMe c = not (isPrint c) || c == '\\'  instance Eq Literal where-  LitNat _ n    == LitNat _ m    = n == m+  LitNat n    == LitNat m    = n == m   -- ASR (2016-09-29). We use bitwise equality for comparing Double   -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove   -- a contradiction (see Issue #2169).-  LitWord64 _ n == LitWord64 _ m = n == m-  LitFloat _ x  == LitFloat _ y  = identicalIEEE x y || (isNaN x && isNaN y)-  LitString _ s == LitString _ t = s == t-  LitChar _ c   == LitChar _ d   = c == d-  LitQName _ x  == LitQName _ y  = x == y-  LitMeta _ f x == LitMeta _ g y = (f, x) == (f, y)-  _             == _             = False+  LitWord64 n == LitWord64 m = n == m+  LitFloat x  == LitFloat y  = doubleDenotEq x y+  LitString s == LitString t = s == t+  LitChar c   == LitChar d   = c == d+  LitQName x  == LitQName y  = x == y+  LitMeta f x == LitMeta g y = (f, x) == (g, y)+  _           == _             = False  instance Ord Literal where-  LitNat _ n    `compare` LitNat _ m    = n `compare` m-  LitWord64 _ n `compare` LitWord64 _ m = n `compare` m-  LitFloat _ x  `compare` LitFloat _ y  = compareFloat x y-  LitString _ s `compare` LitString _ t = s `compare` t-  LitChar _ c   `compare` LitChar _ d   = c `compare` d-  LitQName _ x  `compare` LitQName _ y  = x `compare` y-  LitMeta _ f x `compare` LitMeta _ g y = (f, x) `compare` (g, y)+  LitNat n    `compare` LitNat m    = n `compare` m+  LitWord64 n `compare` LitWord64 m = n `compare` m+  LitFloat x  `compare` LitFloat y  = doubleDenotOrd x y+  LitString s `compare` LitString t = s `compare` t+  LitChar c   `compare` LitChar d   = c `compare` d+  LitQName x  `compare` LitQName y  = x `compare` y+  LitMeta f x `compare` LitMeta g y = (f, x) `compare` (g, y)   compare LitNat{}    _ = LT   compare _ LitNat{}    = GT   compare LitWord64{} _ = LT@@ -95,57 +85,22 @@   -- compare LitMeta{} _   = LT   -- compare _ LitMeta{}   = GT --- NOTE: This is not the same ordering as primFloatNumericalEquality!--- This ordering must be a total order of all allowed float values,--- while primFloatNumericalEquality is only a preorder-compareFloat :: Double -> Double -> Ordering-compareFloat x y-  | identicalIEEE x y          = EQ-  | isNegInf x                 = LT-  | isNegInf y                 = GT-  | isNaN x && isNaN y         = EQ-  | isNaN x                    = LT-  | isNaN y                    = GT-  | isNegativeZero x && x == y = LT-  | isNegativeZero y && x == y = GT-  | otherwise                  = compare x y-  where-    isNegInf z = z < 0 && isInfinite z--instance HasRange Literal where-  getRange (LitNat    r _) = r-  getRange (LitWord64 r _) = r-  getRange (LitFloat  r _) = r-  getRange (LitString r _) = r-  getRange (LitChar   r _) = r-  getRange (LitQName  r _) = r-  getRange (LitMeta r _ _) = r--instance SetRange Literal where-  setRange r (LitNat    _ x) = LitNat    r x-  setRange r (LitWord64 _ x) = LitWord64 r x-  setRange r (LitFloat  _ x) = LitFloat  r x-  setRange r (LitString _ x) = LitString r x-  setRange r (LitChar   _ x) = LitChar   r x-  setRange r (LitQName  _ x) = LitQName  r x-  setRange r (LitMeta _ f x) = LitMeta   r f x- instance KillRange Literal where-  killRange (LitNat    r x) = LitNat    (killRange r) x-  killRange (LitWord64 r x) = LitWord64 (killRange r) x-  killRange (LitFloat  r x) = LitFloat  (killRange r) x-  killRange (LitString r x) = LitString (killRange r) x-  killRange (LitChar   r x) = LitChar   (killRange r) x-  killRange (LitQName  r x) = killRange2 LitQName r x-  killRange (LitMeta r f x) = LitMeta   (killRange r) f x+  killRange (LitNat    x) = LitNat    x+  killRange (LitWord64 x) = LitWord64 x+  killRange (LitFloat  x) = LitFloat  x+  killRange (LitString x) = LitString x+  killRange (LitChar   x) = LitChar   x+  killRange (LitQName  x) = killRange1 LitQName x+  killRange (LitMeta f x) = LitMeta f x  -- | Ranges are not forced.  instance NFData Literal where-  rnf (LitNat _ _)    = ()-  rnf (LitWord64 _ _) = ()-  rnf (LitFloat _ _)  = ()-  rnf (LitString _ a) = rnf a-  rnf (LitChar _ _)   = ()-  rnf (LitQName _ a)  = rnf a-  rnf (LitMeta _ _ x) = rnf x+  rnf (LitNat _     ) = ()+  rnf (LitWord64 _  ) = ()+  rnf (LitFloat _   ) = ()+  rnf (LitString _  ) = ()+  rnf (LitChar _    ) = ()+  rnf (LitQName a   ) = rnf a+  rnf (LitMeta _ x  ) = rnf x

src/full/Agda/Syntax/Notation.hs view

@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable  #-} + {-| 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. @@ -17,24 +17,26 @@  import Control.DeepSeq import Control.Monad+import Control.Monad.Except  import qualified Data.List as List import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -import Data.Data (Data)+import GHC.Generics (Generic)  import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common import Agda.Syntax.Concrete.Name+import Agda.Syntax.Concrete.Pretty() import Agda.Syntax.Position -import Agda.Utils.Except ( MonadError(throwError) )-import Agda.Utils.Functor ((<&>)) import Agda.Utils.Lens import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null+import Agda.Utils.Pretty  import Agda.Utils.Impossible @@ -92,14 +94,14 @@   | PostfixNotation -- ^ Ex: @bla_blub_@.   | NonfixNotation  -- ^ Ex: @bla_blub@.   | NoNotation-   deriving (Eq, Show)+   deriving (Eq, Show, Generic)  -- | Classify a notation by presence of leading and/or trailing -- /normal/ holes. notationKind :: Notation -> NotationKind notationKind []  = NoNotation-notationKind syn =-  case (isNormalHole $ head syn, isNormalHole $ last syn) of+notationKind (h:syn) =+  case (isNormalHole h, isNormalHole $ last1 h syn) of     (True , True ) -> InfixNotation     (True , False) -> PostfixNotation     (False, True ) -> PrefixNotation@@ -124,11 +126,9 @@ mkNotation holes ids = do   unless uniqueHoleNames     $ throwError "syntax must use unique argument names"   let xs :: Notation = map mkPart ids-  unless (isAlternating xs)  $ throwError $ concat-     [ "syntax must alternate holes ("+  unless (noAdjacentHoles xs)  $ throwError $ concat+     [ "syntax must not contain adjacent holes ("      , prettyHoles-     , ") and non-holes ("-     , prettyNonHoles xs      , ")"      ]   unless (isExprLinear xs)   $ throwError "syntax must use holes exactly once"@@ -146,16 +146,6 @@       prettyHoles :: String       prettyHoles = List.unwords $ map (rawNameToString . rangedThing) holeNames -      nonHoleNames :: Notation -> [RString]-      nonHoleNames xs = flip mapMaybe xs $ \case-        WildHole{}   -> Just $ unranged "_"-        IdPart x     -> Just x-        BindHole{}   -> Nothing-        NormalHole{} -> Nothing--      prettyNonHoles :: Notation -> String-      prettyNonHoles = List.unwords . map (rawNameToString . rangedThing) . nonHoleNames-       mkPart ident = maybe (IdPart ident) (`withRangeOf` ident) $ lookup ident holeMap        holeNumbers   = [0 .. length holes - 1]@@ -205,10 +195,11 @@                           [ i | (i, h) <- numberedHoles,                                 LambdaHole x _ <- [namedArg h], rangedThing x /= "_" ] -      isAlternating :: [GenPart] -> Bool-      isAlternating []       = __IMPOSSIBLE__-      isAlternating [x]      = True-      isAlternating (x:y:xs) = isAHole x /= isAHole y && isAlternating (y:xs)+      noAdjacentHoles :: [GenPart] -> Bool+      noAdjacentHoles []       = __IMPOSSIBLE__+      noAdjacentHoles [x]      = True+      noAdjacentHoles (x:y:xs) =+        not (isAHole x && isAHole y) && noAdjacentHoles (y:xs)        isSingleHole :: [GenPart] -> Bool       isSingleHole = \case@@ -231,7 +222,7 @@   , notaIsOperator :: Bool     -- ^ True if the notation comes from an operator (rather than a     -- syntax declaration).-  } deriving Show+  } deriving (Show, Generic)  instance LensFixity NewNotation where   lensFixity f nota = f (notaFixity nota) <&> \ fx -> nota { notaFixity = fx }@@ -260,10 +251,10 @@ --   @M.for x ∈ xs return e@, or @x ℕ.+ y@. notationNames :: NewNotation -> [QName] notationNames (NewNotation q _ _ parts _) =-  zipWith ($) (reQualify : repeat QName) [Name noRange InScope [Id $ rangedThing x] | IdPart x <- parts ]+  zipWith ($) (reQualify : repeat QName) [simpleName $ rangedThing x | IdPart x <- parts ]   where     -- The qualification of @q@.-    modules     = init (qnameParts q)+    modules     = List1.init (qnameParts q)     -- Putting the qualification onto @x@.     reQualify x = List.foldr Qual (QName x) modules @@ -272,9 +263,9 @@ --   'Hole's become 'NormalHole's, 'Id's become 'IdParts'. --   If 'Name' has no 'Hole's, it returns 'noNotation'. syntaxOf :: Name -> Notation-syntaxOf (NoName _ _)    = noNotation-syntaxOf (Name _ _ [_])  = noNotation-syntaxOf (Name _ _ xs)   = mkSyn 0 xs+syntaxOf y+  | isOperator y = mkSyn 0 $ List1.toList $ nameNameParts y+  | otherwise    = noNotation   where     -- Turn a concrete name into a Notation,     -- numbering the holes from left to right.@@ -365,7 +356,7 @@   , sectIsSection :: Bool     -- ^ 'False' for non-sectioned operators.   }-  deriving Show+  deriving (Show, Generic)  -- | Converts a notation to a (non-)section. @@ -376,3 +367,30 @@   , sectLevel     = Just (fixityLevel (notaFixity n))   , sectIsSection = False   }+++-- * Pretty printing++instance Pretty NewNotation where+  pretty (NewNotation x _xs fx nota isOp) = hsepWith "=" px pn+    where+    px = fsep [ if isOp then empty else "syntax" , pretty fx , pretty x ]+    pn = if isOp then empty else pretty nota++instance Pretty NotationKind where pretty = pshow++instance Pretty NotationSection where+  pretty (NotationSection nota kind mlevel isSection)+    | isSection = fsep+        [ "section"+        , pretty kind+        , maybe empty pretty mlevel+        , pretty nota+        ]+    | otherwise = pretty nota++-- NFData instances++instance NFData NotationKind+instance NFData NewNotation+instance NFData NotationSection

src/full/Agda/Syntax/Parser.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.Syntax.Parser     ( -- * Types@@ -24,11 +23,11 @@     , runPMIO     ) where -import Control.Arrow (second) import Control.Exception-import Control.Monad (forM_)+import Control.Monad.Except import Control.Monad.State +import Data.Bifunctor import qualified Data.List as List import Data.Text.Lazy (Text) @@ -42,22 +41,48 @@ import Agda.Syntax.Concrete import Agda.Syntax.Parser.Tokens -import Agda.Utils.Except-  ( ExceptT-  , MonadError(throwError)-  , runExceptT-  ) import Agda.Utils.FileName import Agda.Utils.IO.UTF8 (readTextFile)+import Agda.Utils.Maybe   (forMaybe) import qualified Agda.Utils.Maybe.Strict as Strict  ------------------------------------------------------------------------ -- Wrapping parse results +-- | A monad for handling parse errors and warnings.++newtype PM a = PM { unPM :: ExceptT ParseError (StateT [ParseWarning] IO) a }+  deriving ( Functor, Applicative, Monad, MonadIO+           , MonadError ParseError, MonadState [ParseWarning]+           )++-- | Run a 'PM' computation, returning a list of warnings in first-to-last order+--   and either a parse error or the parsed thing.++runPMIO :: (MonadIO m) => PM a -> m (Either ParseError a, [ParseWarning])+runPMIO = liftIO . fmap (second reverse) . flip runStateT [] . runExceptT . unPM++-- | Add a 'ParseWarning'.++warning :: ParseWarning -> PM ()+warning w = PM (modify (w:))++-- | Embed a 'ParseResult' as 'PM' computation.+ wrap :: ParseResult a -> PM a-wrap (ParseOk _ x)      = return x wrap (ParseFailed err)  = throwError err+wrap (ParseOk s x)      = do+  modify' (parseWarnings s ++)+  return x +wrapM :: IO (ParseResult a) -> PM a+wrapM m = liftIO m >>= wrap++-- | Returns the contents of the given file.++readFilePM :: AbsolutePath -> PM Text+readFilePM path = wrapIOM (ReadFileError path) (readTextFile $ filePath path)+ wrapIOM :: (MonadError e m, MonadIO m) => (IOError -> e) -> IO a -> m a wrapIOM f m = do   a <- liftIO$ (Right <$> m) `catch` (\err -> return$ Left (err :: IOError))@@ -65,20 +90,6 @@     Right x  -> return x     Left err -> throwError (f err) -wrapM :: IO (ParseResult a) -> PM a-wrapM m = liftIO m >>= wrap---- | A monad for handling parse results-newtype PM a = PM { unPM :: ExceptT ParseError (StateT [ParseWarning] IO) a }-               deriving (Functor, Applicative, Monad,-                         MonadError ParseError, MonadIO)--warning :: ParseWarning -> PM ()-warning w = PM (modify (w:))--runPMIO :: (MonadIO m) => PM a -> m (Either ParseError a, [ParseWarning])-runPMIO = liftIO . fmap (second reverse) . flip runStateT [] . runExceptT . unPM- ------------------------------------------------------------------------ -- Parse functions @@ -92,35 +103,53 @@  type LiterateParser a = Parser a -> [Layer] -> PM a +-- | Initial state for lexing.++normalLexState :: [LexState]+normalLexState = [normal]++-- | Initial state for lexing with top-level layout.++layoutLexState :: [LexState]+layoutLexState = [layout, normal]++-- | Parse without top-level layout.+ parse :: Parser a -> String -> PM a-parse p = wrapM . return . M.parse (parseFlags p) [normal] (parser p)+parse p = wrapM . return . M.parse (parseFlags p) normalLexState (parser p) -parseStringFromFile :: SrcFile -> Parser a -> String -> PM a-parseStringFromFile src p = wrapM . return . M.parseFromSrc (parseFlags p) [layout, normal] (parser p) src+-- | Parse with top-level layout. +parseFileFromString+  :: SrcFile   -- ^ Name of source file.+  -> Parser a  -- ^ Parser to use.+  -> String    -- ^ Contents of source file.+  -> PM a+parseFileFromString src p = wrapM . return . M.parseFromSrc (parseFlags p) layoutLexState (parser p) src++-- | Parse with top-level layout.+ parseLiterateWithoutComments :: LiterateParser a-parseLiterateWithoutComments p layers = parseStringFromFile (literateSrcFile layers) p $ illiterate layers+parseLiterateWithoutComments p layers = parseFileFromString (literateSrcFile layers) p $ illiterate layers +-- | Parse with top-level layout.+ parseLiterateWithComments :: LiterateParser [Token] parseLiterateWithComments p layers = do-  code <- map Left <$> parseLiterateWithoutComments p layers-  let literate = Right <$> filter (not . isCodeLayer) layers-  let (terms, overlaps) = interleaveRanges code literate+  code <- parseLiterateWithoutComments p layers+  let literate = filter (not . isCodeLayer) layers+  let (terms, overlaps) = interleaveRanges (map Left code) (map Right literate)+   forM_ (map fst overlaps) $ \c ->     warning$ OverlappingTokensWarning { warnRange = getRange c } -  return$ concat [ case m of-                       Left t -> [t]-                       Right (Layer Comment interval s) -> [TokTeX (interval, s)]-                       Right (Layer Markup interval s) -> [TokMarkup (interval, s)]-                       Right (Layer Code _ _) -> []-                   | m <- terms ]+  return $ forMaybe terms $ \case+    Left t                           -> Just t+    Right (Layer Comment interval s) -> Just $ TokTeX    (interval, s)+    Right (Layer Markup  interval s) -> Just $ TokMarkup (interval, s)+    Right (Layer Code _ _)           -> Nothing --- | Returns the contents of the given file. -readFilePM :: AbsolutePath -> PM Text-readFilePM path = wrapIOM (ReadFileError path) (readTextFile $ filePath path)- parseLiterateFile   :: Processor   -> Parser a@@ -133,7 +162,7 @@ parseLiterateFile po p path = parseLiterate p p . po (startPos (Just path))  parsePosString :: Parser a -> Position -> String -> PM a-parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) [normal] (parser p)+parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) normalLexState (parser p)  -- | Extensions supported by `parseFile`. @@ -151,8 +180,7 @@   -> PM (a, FileType) parseFile p file input =   if ".agda" `List.isSuffixOf` filePath file then-    (, AgdaFileType) <$> Agda.Syntax.Parser.parseStringFromFile-                         (Strict.Just file) p input+    (, AgdaFileType) <$> parseFileFromString (Strict.Just file) p input   else     go literateProcessors   where@@ -171,33 +199,36 @@ -- | Parses a module.  moduleParser :: Parser Module-moduleParser = Parser { parser = P.moduleParser-                      , parseFlags = withoutComments-                      , parseLiterate = parseLiterateWithoutComments-                      }+moduleParser = Parser+  { parser        = P.moduleParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }  -- | Parses a module name.  moduleNameParser :: Parser QName-moduleNameParser = Parser { parser = P.moduleNameParser-                          , parseFlags = withoutComments-                          , parseLiterate = parseLiterateWithoutComments-                          }+moduleNameParser = Parser+  { parser        = P.moduleNameParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }  -- | Parses an expression.  exprParser :: Parser Expr-exprParser = Parser { parser = P.exprParser-                    , parseFlags = withoutComments-                    , parseLiterate = parseLiterateWithoutComments-                    }+exprParser = Parser+  { parser        = P.exprParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }  -- | Parses an expression followed by a where clause.  exprWhereParser :: Parser ExprWhere exprWhereParser = Parser-  { parser     = P.exprWhereParser-  , parseFlags = withoutComments+  { parser        = P.exprWhereParser+  , parseFlags    = withoutComments   , parseLiterate = parseLiterateWithoutComments   } @@ -213,10 +244,11 @@ -- | Gives the parsed token stream (including comments).  tokensParser :: Parser [Token]-tokensParser = Parser { parser = P.tokensParser-                      , parseFlags = withComments-                      , parseLiterate = parseLiterateWithComments-                      }+tokensParser = Parser+  { parser        = P.tokensParser+  , parseFlags    = withComments+  , parseLiterate = parseLiterateWithComments+  }  -- | Keep comments in the token stream generated by the lexer.

src/full/Agda/Syntax/Parser/Alex.hs view

@@ -8,7 +8,7 @@     , alexInputPrevChar     , alexGetChar, alexGetByte       -- * Lex actions-    , LexAction, LexPredicate+    , LexAction(..), LexPredicate     , (.&&.), (.||.), not'     , PreviousInput, CurrentInput, TokenLength       -- * Monad operations@@ -91,7 +91,7 @@  --------------------------------------------------------------------------}  getLexInput :: Parser AlexInput-getLexInput = getInp <$> get+getLexInput = gets getInp     where         getInp s = AlexInput                     { lexSrcFile    = parseSrcFile s@@ -119,7 +119,23 @@  -- | In the lexer, regular expressions are associated with lex actions who's --   task it is to construct the tokens.-type LexAction r    = PreviousInput -> CurrentInput -> TokenLength -> Parser r+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++instance Monad LexAction where+  return = pure+  m >>= k  = LexAction $ \ a b c -> do+    r <- runLexAction m a b c+    runLexAction (k r) a b c++instance MonadState ParseState LexAction where+  get   = LexAction $ \ _ _ _ -> get+  put s = LexAction $ \ _ _ _ -> 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

@@ -32,8 +32,10 @@ --   In the end the comment is discarded and 'lexToken' is called to lex a real --   token. nestedComment :: LexAction Token-nestedComment inp inp' _ =+nestedComment = LexAction $ \ inp inp' _ ->     do  setLexInput inp'+        let err :: forall a. String -> LookAhead a+            err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{-'"         runLookAhead err $ skipBlock "{-" "-}"         keep <- keepCommentsM         if keep then do@@ -46,21 +48,20 @@           return $ TokComment (i, s)          else           lexToken-    where-        err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{-'" + -- | Lex a hole (@{! ... !}@). Holes can be nested. --   Returns @'TokSymbol' 'SymQuestionMark'@. hole :: LexAction Token-hole inp inp' _ =+hole = LexAction $ \ inp inp' _ ->     do  setLexInput inp'+        let err :: forall a. String -> LookAhead a+            err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{!'"         runLookAhead err $ skipBlock "{!" "!}"         p <- lexPos <$> getLexInput         return $           TokSymbol SymQuestionMark $           posToInterval (lexSrcFile inp) (lexPos inp) p-    where-        err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{!'"  -- | Skip a block of text enclosed by the given open and close strings. Assumes --   the first open string has been consumed. Open-close pairs may be nested.

src/full/Agda/Syntax/Parser/Layout.hs view

@@ -6,26 +6,110 @@      > f x = x'     >   where-    >     x' = case x of { True -> False; False -> ...+    >     x' = do y <- foo x; bar ...      At the @...@ the layout context would be -    > [NoLayout, Layout 4, Layout 0]+    > [Layout 12, Layout 4, Layout 0] -    The closest layout block is the one containing the @case@ branches.  This-    block starts with an open brace (@\'{\'@) and so doesn't use layout.  The-    second closest block is the @where@ clause.  Here, there is no open brace-    so the block is started by the @x'@ token which has indentation 4. Finally-    there is a top-level layout block with indentation 0.+    The closest layout block is the one following @do@ which is+    started by token @foo@ at column 12.  The second closest block is the+    @where@ clause started by the @x'@ token which has indentation 4.+    Finally, there is a top-level layout block with indentation 0.++    In April 2021 we changed layout handling in the lexer to allow+    stacking of layout keywords on the same line, e.g.:++    > private module M where+    >    postulate A : Set+    >              private+    >                B : Set++    The layout columns in the layout context (stack of layout blocks) can+    have 'LayoutStatus' either 'Tentative' or 'Confirmed'. New layout+    columns following a layout keyword are tentative until we see a new+    line. E.g.++      - The first @private@ block (column 8) is 'Tentative' when we+        encounter the layout keyword @where@.++      - The @postulate@ block (column 12) is 'Tentative' until the newline+        after @A : Set@.++    In contrast,++      - The @module@ block (column 2) is 'Confirmed' from the beginning+        since the first token (@postulate@) after the layout keyword @where@+        is on a new line.++      - The second @private@ block (column 14) is also 'Confirmed' from the+        beginning (for the same reason).++    A new layout column has to be strictly above the last __confirmed__+    column only. E.g., when encountering @postulate@ at column 2 after+    @where@, the confirmed column is still 0, so this is a valid start of+    the block following @where@.++    The column 8 of the @private@ block never enters the 'Confirmed' status+    but remains 'Tentative'. Also, this block can never get more than the+    one declaration it has (@module...@), because when the @module@ block+    closes due to a column \< 2, it closes as well. One could say that+    tentative blocks buried under confirmed blocks are passive, the only+    wait for their closing.++    To implement the process of block confirmation (function+    'confirmLayout'), the lexer has to act on newline characters (except for+    those in a block comment).++      - In ordinary mode, when encountering a newline, we confirm the top+        unconfirmed blocks. Example: The newline after @A : Set@ confirms+        the column 12 after @postulate@. Function: 'confirmLayoutAtNewLine',+        state @bol@.++      - In the @layout@ state following a layout keyword, a newline does not+        confirm any block, but announces that the next block should be+        confirmed from the start. Function: 'confirmedLayoutComing'.++    In order to implement 'confirmedLayoutComing' we have a 'LayoutStatus'+    flag in the parse state (field 'stateLayStatus'). By default, for a new+    layout block, the status is 'Tentative' (unless we saw a newline).++    New layout blocks are created as follows. When a layout keyword is+    encountered, we enter lexer state 'layout' via function 'withLayout'.+    When we exit the 'layout' state via 'newLayoutBlock' with a token that+    marks the new layout column, we push a new 'LayoutBlock' onto the+    'LayoutContext' using the given column and the current 'parseLayStatus'+    which is then reset to 'Tentative'.++    The new block is actually only pushed if the column is above the last+    confirmed layout column ('confirmedLayoutColumn'). If this check fails,+    we instead enter the 'empty_layout' state. This state produces the+    closing brace and is immediately left for 'bol' (beginning of line).++    (Remark: In 'bol' we might confirm some tentative top blocks, but this+    is irrelevant, since they will be closed immediately, given that the+    current token is left of the confirmed column, and tentative columns+    above it must be to the right of this column.)++    The 'offsideRule' (state 'bol') is unchanged. It checks how the first+    token on a new line relates to the top layout column, be it tentative or+    confirmed. (Since we are on a new line, 'Tentative' can only happen when+    we popped some 'Confirmed' columns and continue popping the top+    'Tentative' columns here.) While the token is to the left of the layout+    column, we keep closing blocks.+ -} module Agda.Syntax.Parser.Layout-    ( openBrace, closeBrace-    , withLayout+    ( withLayout     , offsideRule-    , newLayoutContext+    , newLayoutBlock     , emptyLayout+    , confirmLayout     ) where +import Control.Monad        ( when )+import Control.Monad.State  ( gets, modify )+ import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad@@ -33,34 +117,18 @@ import Agda.Syntax.Parser.LexActions import Agda.Syntax.Position ---- | Executed upon lexing an open brace (@\'{\'@). Enters the 'NoLayout'---   context.-openBrace :: LexAction Token-openBrace = token $ \_ ->-    do  pushContext NoLayout-        i <- getParseInterval-        return (TokSymbol SymOpenBrace i)-+import Agda.Utils.Functor ((<&>)) -{-| Executed upon lexing a close brace (@\'}\'@). Exits the current layout-    context. This might look a bit funny--the lexer will happily use a close-    brace to close a context open by a virtual brace. This is not a problem-    since the parser will make sure the braces are appropriately matched.--}-closeBrace :: LexAction Token-closeBrace = token $ \_ ->-    do  popContext-        i <- getParseInterval-        return (TokSymbol SymCloseBrace i)+import Agda.Utils.Impossible +{-| Executed for the first token in each line (see 'Agda.Syntax.Parser.Lexer.bol'),+    except when the last token was a layout keyword. -{-| Executed for the first token in each line (see 'Agda.Syntax.Parser.Lexer.bol').     Checks the position of the token relative to the current layout context.     If the token is      - /to the left/ :-        Exit the current context and a return virtual close brace (stay in the+        Exit the current block and a return virtual close brace (stay in the         'Agda.Syntax.Parser.Lexer.bol' state).      - /same column/ :@@ -70,50 +138,44 @@     - /to the right/ :         Exit the 'Agda.Syntax.Parser.Lexer.bol' state and continue lexing. -    If the current block doesn't use layout (i.e. it was started by-    'openBrace') all positions are considered to be /to the right/. -} offsideRule :: LexAction Token-offsideRule inp _ _ =-    do  offs <- getOffside p-        case offs of-            LT  -> do   popContext-                        return (TokSymbol SymCloseVirtualBrace i)-            EQ  -> do   popLexState-                        return (TokSymbol SymVirtualSemi i)-            GT  -> do   popLexState-                        lexToken-    where-        p = lexPos inp+offsideRule = LexAction $ \ inp _ _ -> do+    let p = lexPos inp         i = posToInterval (lexSrcFile inp) p p+    getOffside p >>= \case+        LT  -> do   popBlock+                    return (TokSymbol SymCloseVirtualBrace i)+        EQ  -> do   popLexState+                    return (TokSymbol SymVirtualSemi i)+        GT  -> do   popLexState+                    lexToken   {-| This action is only executed from the 'Agda.Syntax.Parser.Lexer.empty_layout'     state. It will exit this state, enter the 'Agda.Syntax.Parser.Lexer.bol' state,     and return a virtual close brace (closing the empty layout block started-    by 'newLayoutContext').+    by 'newLayoutBlock'). -} emptyLayout :: LexAction Token-emptyLayout inp _ _ =-    do  popLexState-        pushLexState bol-        return (TokSymbol SymCloseVirtualBrace i)-    where-        p = lexPos inp+emptyLayout = LexAction $ \ inp _ _ -> do+    let p = lexPos inp         i = posToInterval (lexSrcFile inp) p p+    popLexState+    pushLexState bol+    return (TokSymbol SymCloseVirtualBrace i)  -{-| Start a new layout context. This is one of two ways to get out of the-    'Agda.Syntax.Parser.Lexer.layout' state (the other is 'openBrace'). There are+{-| Start a new layout block. This is how to get out of the+    'Agda.Syntax.Parser.Lexer.layout' state. There are     two possibilities: -    - The current token is to the right of the current layout context (or we're-      in a no layout context).+    - The current token is to the right of the confirmed layout column. -    - The current token is to the left of or in the same column as the current-      context.+    - The current token is to the left of or in the same column as the confirmed+      layout column. -    In the first case everything is fine and we enter a new layout context at+    In the first case everything is fine and we enter a new layout block at     the column of the current token. In the second case we have an empty layout     block so we enter the 'Agda.Syntax.Parser.Lexer.empty_layout' state. In both     cases we return a virtual open brace without consuming any input.@@ -124,27 +186,71 @@     then enter a state in which the only thing you can do is generate the     second one. -}-newLayoutContext :: LexAction Token-newLayoutContext inp _ _ =-    do  let offset = posCol p-        ctx <- topContext-        case ctx of-            Layout prevOffs | prevOffs >= offset ->-                do  pushLexState empty_layout-                    return (TokSymbol SymOpenVirtualBrace i)-            _ ->-                do  pushContext (Layout offset)-                    return (TokSymbol SymOpenVirtualBrace i)-    where-        p = lexPos inp+newLayoutBlock :: LexAction Token+newLayoutBlock = LexAction $ \ inp _ _ -> do+    let p = lexPos inp         i = posToInterval (lexSrcFile inp) p p+        offset = posCol p+    status   <- popPendingLayout+    kw       <- gets parseLayKw+    prevOffs <- confirmedLayoutColumn <$> getContext+    if prevOffs >= offset+        then pushLexState empty_layout+        else do+            when (status == Confirmed) $+              modifyContext $ confirmTentativeBlocks $ Just offset+            pushBlock $ Layout kw status offset+    return $ TokSymbol SymOpenVirtualBrace i+  where +    -- Get and reset the status of the coming layout block.+    popPendingLayout :: Parser LayoutStatus+    popPendingLayout = do+        status <- gets parseLayStatus+        resetLayoutStatus+        return status +    -- The confirmed layout column, or 0 if there is none.+    confirmedLayoutColumn :: LayoutContext -> Column+    confirmedLayoutColumn = \case+       Layout _ Confirmed c : _   -> c+       Layout _ Tentative _ : cxt -> confirmedLayoutColumn cxt+       [] -> 0 -- should only happen when looking at the first token (top-level layout)+ -- | Compute the relative position of a location to the --   current layout context. getOffside :: Position' a -> Parser Ordering getOffside loc =-    do  ctx <- topContext-        return $ case ctx of-            Layout n    -> compare (posCol loc) n-            _           -> GT+    getContext <&> \case+        Layout _ _ n : _ -> compare (posCol loc) n+        _                -> GT++-- | At a new line, we confirm either existing tentative layout+--   columns, or, if the last token was a layout keyword, the expected+--   new layout column.+confirmLayout :: Parser ()+confirmLayout = getLexState >>= \ case+  s : _ | s == layout -> confirmedLayoutComing+  _                   -> confirmLayoutAtNewLine+  where++  -- Mark the pending layout block as 'Confirmed'.+  confirmedLayoutComing :: Parser ()+  confirmedLayoutComing = modify $ \ s -> s { parseLayStatus = Confirmed }++  -- Encountering a newline outside of a 'layout' state we confirm top+  -- tentative layout columns.+  confirmLayoutAtNewLine :: Parser ()+  confirmLayoutAtNewLine = modifyContext $ confirmTentativeBlocks Nothing++-- | Confirm all top 'Tentative' layout columns.+-- If a column is given, only those below the given column.+--+-- The code ensures that the newly created 'Definitive' columns+-- are strictly decreasing.+--+confirmTentativeBlocks :: Maybe Column -> LayoutContext -> LayoutContext+confirmTentativeBlocks mcol = \case+    Layout kw Tentative col : cxt | maybe True (col <) mcol+            -> Layout kw Confirmed col : confirmTentativeBlocks (Just col) cxt+    cxt  -> cxt

src/full/Agda/Syntax/Parser/Layout.hs-boot view

@@ -1,8 +1,13 @@ module Agda.Syntax.Parser.Layout where -import Agda.Syntax.Parser.Alex-import Agda.Syntax.Parser.Tokens+import Agda.Syntax.Parser.Alex   (LexAction)+import Agda.Syntax.Parser.Monad  (Parser)+import Agda.Syntax.Parser.Tokens (Token)  offsideRule      :: LexAction Token-newLayoutContext :: LexAction Token+newLayoutBlock   :: LexAction Token emptyLayout      :: LexAction Token++confirmLayout    :: Parser ()+-- confirmLayoutAtNewLine :: Parser ()+-- confirmedLayoutComing  :: Parser ()

src/full/Agda/Syntax/Parser/LexActions.hs view

@@ -9,6 +9,7 @@     , token     , withInterval, withInterval', withInterval_     , withLayout+    , andThen, skip     , begin, end, beginWith, endWith     , begin_, end_     , lexError@@ -18,9 +19,14 @@     , followedBy, eof, inState     ) where +import Control.Monad.State (modify)++import Data.Bifunctor import Data.Char+import Data.List import Data.Maybe +import Agda.Syntax.Common (pattern Ranged) import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad@@ -29,7 +35,6 @@ import Agda.Syntax.Literal  import Agda.Utils.List-import Agda.Utils.Tuple  import Agda.Utils.Impossible @@ -70,7 +75,7 @@         case alexScanUser (lss, flags) inp (headWithDefault __IMPOSSIBLE__ lss) of             AlexEOF                     -> returnEOF inp             AlexSkip inp' len           -> skipTo inp'-            AlexToken inp' len action   -> fmap postToken $ action inp inp' len+            AlexToken inp' len action   -> postToken <$> runLexAction action inp inp' len             AlexError i                 -> parseError $ concat               [ "Lexical error"               , case listToMaybe $ lexInput i of@@ -96,14 +101,6 @@ postToken (TokId (r, "\x2988")) = TokSymbol SymCloseIdiomBracket r postToken (TokId (r, "\x2987\x2988")) = TokSymbol SymEmptyIdiomBracket r postToken (TokId (r, "\x2200")) = TokKeyword KwForall r-postToken (TokId (r, s))-  | set == "Set" && all isSub n = TokSetN (r, readSubscript n)-  where-    (set, n)      = splitAt 3 s-postToken (TokId (r, s))-  | prop == "Prop" && all isSub n = TokPropN (r, readSubscript n)-  where-    (prop, n)     = splitAt 4 s postToken t = t  {--------------------------------------------------------------------------@@ -112,13 +109,12 @@  -- | The most general way of parsing a token. token :: (String -> Parser tok) -> LexAction tok-token action inp inp' len =+token action = LexAction $ \ inp inp' len ->     do  setLexInput inp'+        let t = take len $ lexInput inp         setPrevToken t         setLastPos $ lexPos inp         action t-    where-        t = take len $ lexInput inp  -- | Parse a token from an 'Interval' and the lexed string. withInterval :: ((Interval, String) -> tok) -> LexAction tok@@ -128,7 +124,7 @@  -- | Like 'withInterval', but applies a function to the string. withInterval' :: (String -> a) -> ((Interval, a) -> tok) -> LexAction tok-withInterval' f t = withInterval (t . (id -*- f))+withInterval' f t = withInterval (t . second f)  -- | Return a token without looking at the lexed string. withInterval_ :: (Interval -> r) -> LexAction r@@ -137,59 +133,85 @@  -- | Executed for layout keywords. Enters the 'Agda.Syntax.Parser.Lexer.layout' --   state and performs the given action.-withLayout :: LexAction r -> LexAction r-withLayout a i1 i2 n =-    do  pushLexState layout-        a i1 i2 n+withLayout :: Keyword -> LexAction r -> LexAction r+withLayout kw a = pushLexState layout `andThen` setLayoutKw `andThen` a+  where+  setLayoutKw = modify $ \ st -> st { parseLayKw = kw } +infixr 1 `andThen` +-- | Prepend some parser manipulation to an action.+andThen :: Parser () -> LexAction r -> LexAction r+andThen cmd a = LexAction $ \ inp inp' n -> do+  cmd+  runLexAction a inp inp' n++-- | Visit the current lexeme again.+revisit :: LexAction Token+revisit = LexAction $ \ _ _ _ -> lexToken++-- | Throw away the current lexeme.+skip :: LexAction Token+skip = LexAction $ \ _ inp' _ -> skipTo inp'+ -- | Enter a new state without consuming any input. begin :: LexState -> LexAction Token-begin code _ _ _ =-    do  pushLexState code-        lexToken+begin code = beginWith code revisit +-- | Exit the current state without consuming any input.+end :: LexAction Token+end = endWith revisit  -- | Enter a new state throwing away the current lexeme. begin_ :: LexState -> LexAction Token-begin_ code _ inp' _ =-    do  pushLexState code-        skipTo inp'+begin_ code = beginWith code skip  -- | Exit the current state throwing away the current lexeme. end_ :: LexAction Token-end_ _ inp' _ =-    do  popLexState-        skipTo inp'-+end_ = endWith skip  -- | Enter a new state and perform the given action. beginWith :: LexState -> LexAction a -> LexAction a-beginWith code a inp inp' n =-    do  pushLexState code-        a inp inp' n+beginWith code a = pushLexState code `andThen` a  -- | Exit the current state and perform the given action. endWith :: LexAction a -> LexAction a-endWith a inp inp' n =-    do  popLexState-        a inp inp' n+endWith a = popLexState `andThen` a  --- | Exit the current state without consuming any input-end :: LexAction Token-end _ _ _ =-    do  popLexState-        lexToken- -- | Parse a 'Keyword' token, triggers layout for 'layoutKeywords'. keyword :: Keyword -> LexAction Token-keyword k = layout $ withInterval_ (TokKeyword k)+keyword k =+    case k of++        -- Unconditional layout keyword.+        _ | k `elem` layoutKeywords ->+            withLayout k cont++        -- Andreas, 2021-05-06, issue #5356:+        -- @constructor@ is not a layout keyword after all, replaced by @data _ where@.+        -- -- @constructor@ is not a layout keyword in @record ... where@ blocks,+        -- -- only in @interleaved mutual@ blocks.+        -- KwConstructor -> do+        --     cxt <- getContext+        --     if inMutualAndNotInWhereBlock cxt+        --       then withLayout k cont+        --       else cont++        _ -> cont     where-        layout | k `elem` layoutKeywords  = withLayout-               | otherwise              = id+    cont = withInterval_ (TokKeyword k) +    -- Andreas, 2021-05-06, issue #5356:+    -- @constructor@ is not a layout keyword after all, replaced by @data _ where@.+    -- -- Most recent block decides ...+    -- inMutualAndNotInWhereBlock = \case+    --   Layout KwMutual _ _ : _ -> True+    --   Layout KwWhere  _ _ : _ -> False+    --   _ : bs                  -> inMutualAndNotInWhereBlock bs+    --   []                      -> True  -- For better errors on stray @constructor@ decls. + -- | Parse a 'Symbol' token. symbol :: Symbol -> LexAction Token symbol s = withInterval_ (TokSymbol s)@@ -198,21 +220,32 @@ -- | Parse a number.  number :: String -> Integer-number str = read $ case str of-  '0' : 'x' : num -> str-  _               -> concat $ wordsBy ('_' ==) str+number str = case str of+    '0' : 'x' : num -> parseNumber 16 num+    '0' : 'b' : num -> parseNumber 2  num+    num             -> parseNumber 10 num+    where+        parseNumber :: Integer -> String -> Integer+        parseNumber radix = foldl' (addDigit radix) 0 +        -- We rely on Agda.Syntax.Parser.Lexer to enforce that the digits are+        -- in the correct range (so e.g. the digit 'E' cannot appear in a+        -- binary number).+        addDigit :: Integer -> Integer -> Char -> Integer+        addDigit radix n '_' = n+        addDigit radix n c   = n * radix + fromIntegral (digitToInt c)+ integer :: String -> Integer integer = \case   '-' : str -> - (number str)   str       -> number str  -- | Parse a literal.-literal' :: (String -> a) -> (Range -> a -> Literal) -> LexAction Token-literal' read lit =-  withInterval' read (TokLiteral . uncurry lit . mapFst getRange)+literal' :: (String -> a) -> (a -> Literal) -> LexAction Token+literal' read lit = withInterval' read $ \ (r, a) ->+  TokLiteral $ Ranged (getRange r) $ lit a -literal :: Read a => (Range -> a -> Literal) -> LexAction Token+literal :: Read a => (a -> Literal) -> LexAction Token literal = literal' read  -- | Parse an identifier. Identifiers can be qualified (see 'Name').

src/full/Agda/Syntax/Parser/LexActions.hs-boot view

@@ -12,8 +12,11 @@  withInterval  :: ((Interval, String) -> tok) -> LexAction tok withInterval' :: (String -> a) -> ((Interval, a) -> tok) -> LexAction tok-withLayout :: LexAction r -> LexAction r+withLayout :: Keyword -> LexAction r -> LexAction r +andThen   :: Parser () -> LexAction r -> LexAction r+skip      :: LexAction Token+ begin     :: LexState -> LexAction Token beginWith :: LexState -> LexAction a -> LexAction a endWith   :: LexAction a -> LexAction a@@ -23,8 +26,8 @@ keyword    :: Keyword -> LexAction Token symbol     :: Symbol -> LexAction Token identifier :: LexAction Token-literal    :: Read a => (Range -> a -> Literal) -> LexAction Token-literal'   :: (String -> a) -> (Range -> a -> Literal) -> LexAction Token+literal    :: Read a => (a -> Literal) -> LexAction Token+literal'   :: (String -> a) -> (a -> Literal) -> LexAction Token integer    :: String -> Integer  followedBy    :: Char -> LexPredicate

src/full/Agda/Syntax/Parser/Lexer.x view

@@ -1,11 +1,15 @@ {+#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     #-} -{-# LANGUAGE BangPatterns #-}- {-| The lexer is generated by Alex (<http://www.haskell.org/alex>) and is an     adaptation of GHC's lexer. The main lexing function 'lexer' is called by     the "Agda.Syntax.Parser.Parser" to get the next token from the input.@@ -39,6 +43,7 @@  $digit       = 0-9 $hexdigit    = [ $digit a-f A-F ]+$binarydigit = 0-1 $alpha       = [ A-Z a-z _ ] $op          = [ \- \! \# \$ \% \& \* \+ \/ \< \= \> \^ \| \~ \? \` \[ \] \, \: ] $idstart     = [ $digit $alpha $op ]@@ -47,11 +52,14 @@ $white_notab = $white # \t $white_nonl  = $white_notab # \n -@number       = $digit+ | "0x" $hexdigit+-@prettynumber = $digit+ ([_] $digit+)* | "0x" $hexdigit++@prettynumber = $digit+ ([_] $digit+)*+              | "0x" $hexdigit+ ([_] $hexdigit+)*+              | "0b" $binarydigit+ ([_] $binarydigit+)* @integer      = [\-]? @prettynumber-@exponent     = [eE] [\-\+]? @number-@float        = @integer \. @number @exponent? | @number @exponent+@decimal      = $digit++@exponent     = [eE] [\-\+]? @decimal+@float        = [\-]? @decimal \. @decimal @exponent?+              | [\-]? @decimal @exponent  -- A name can't start with \x (to allow \x -> x). -- Bug in alex: [ _ op ]+ doesn't seem to work!@@ -111,28 +119,32 @@  -- Dashes followed by a name symbol should be parsed as a name. <0,code,bol_,layout_,empty_layout_,imp_dir_>-   "--" .* / { keepComments .&&. (followedBy '\n' .||. eof) }-             { withInterval TokComment }+    "--" .* / { keepComments .&&. (followedBy '\n' .||. eof) }+              { confirmLayout `andThen` withInterval TokComment } <0,code,bol_,layout_,empty_layout_,imp_dir_>-  "--" .* / { followedBy '\n' .||. eof } ;+    "--" .* / { 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.+ -- We need to check the offside rule for the first token on each line.  We -- should not check the offside rule for the end of file token or an -- '\end{code}'-<0,code,imp_dir_> \n    { begin bol_ }+<0,code,imp_dir_> \n    { begin bol_ }  -- Note that @begin@ revisits '\n' in the new state! <bol_>     {-        \n                  ;+        \n                      { confirmLayout `andThen` skip } --      ^ \\ "end{code}"    { end }         () / { not' eof }       { offsideRule }     } --- After a layout keyword there is either an open brace (no layout) or the+-- After a layout keyword the -- indentation of the first token decides the column of the layout block. <layout_>-    {   \n      ;---      \{      { endWith openBrace }-        ()      { endWith newLayoutContext }+    {   \n      { confirmLayout `andThen` skip}+        ()      { endWith newLayoutBlock }     }  -- The only rule for the empty_layout state. Generates a close brace.@@ -162,17 +174,14 @@ <0,code> infix          { keyword KwInfix } <0,code> infixl         { keyword KwInfixL } <0,code> infixr         { keyword KwInfixR }+<0,code> interleaved    { keyword KwInterleaved } <0,code> mutual         { keyword KwMutual } <0,code> abstract       { keyword KwAbstract } <0,code> private        { keyword KwPrivate } <0,code> instance       { keyword KwInstance } <0,code> overlap        { keyword KwOverlap } <0,code> macro          { keyword KwMacro }-<0,code> Set            { keyword KwSet }-<0,code> Prop           { keyword KwProp } <0,code> forall         { keyword KwForall }-<0,code> Set @number    { withInterval' (read . drop 3) TokSetN }-<0,code> Prop @number   { withInterval' (read . drop 4) TokPropN } <0,code> quote          { keyword KwQuote } <0,code> quoteTerm      { keyword KwQuoteTerm } <0,code> unquote        { keyword KwUnquote }@@ -250,10 +259,7 @@   {-| The layout state. Entered when we see a layout keyword ('withLayout') and-    exited either when seeing an open brace ('openBrace') or at the next token-    ('newLayoutContext').--    Update: we don't use braces for layout anymore.+    exited at the next token ('newLayoutBlock'). -} layout :: LexState layout = layout_@@ -269,7 +275,7 @@ fpragma :: LexState fpragma = fpragma_ -{-| We enter this state from 'newLayoutContext' when the token following a+{-| We enter this state from 'newLayoutBlock' when the token following a     layout keyword is to the left of (or at the same column as) the current     layout context. Example: @@ -280,7 +286,7 @@     same indentation as the @data@ definition. What we have to do is insert an     empty layout block @{}@ after the @where@. The only thing that can happen     in this state is that 'emptyLayout' is executed, generating the closing-    brace. The open brace is generated when entering by 'newLayoutContext'.+    brace. The open brace is generated when entering by 'newLayoutBlock'. -} empty_layout :: LexState empty_layout = empty_layout_

src/full/Agda/Syntax/Parser/Literate.hs view

@@ -22,12 +22,15 @@   where  import Prelude hiding (getLine)+import Control.Monad ((<=<)) import Data.Char (isSpace) import Data.List (isPrefixOf)+import Text.Regex.TDFA+ import Agda.Syntax.Common import Agda.Syntax.Position-import Text.Regex.TDFA +import Agda.Utils.List import Agda.Utils.Impossible  -- | Role of a character in the file.@@ -65,7 +68,7 @@ unMkLayers = map ((,) <$> layerRole <*> layerContent)  atomizeLayers :: Layers -> [(LayerRole, Char)]-atomizeLayers = (>>= fmap <$> ((,) . fst) <*> snd) . unMkLayers+atomizeLayers = (fmap <$> ((,) . fst) <*> snd) <=< unMkLayers  -- | Type of a literate preprocessor: --   Invariants:@@ -132,7 +135,7 @@ -- | Check if a character is a blank character.  isBlank :: Char -> Bool-isBlank = (&&) <$> isSpace <*> not . (== '\n')+isBlank = (&&) <$> isSpace <*> (/= '\n')  -- | Short list of extensions for literate Agda files. --   For display purposes.@@ -261,7 +264,7 @@       []                         -> not_code       [[_, before, "::", after]] ->         -- Code starts-        if null before || isBlank (last before) then+        if maybe True isBlank $ lastMaybe before then           (Markup, line) : code rest         else           (Comment, before ++ ":") : (Markup, ":" ++ after) : code rest@@ -285,15 +288,12 @@    -- Process an indented block.   indented :: String -> String -> [(LayerRole, String)]-  indented _   [] = []-  indented ind s  =-    let (line, rest) = getLine s in-    if all isSpace line then-      (Code, line) : indented ind rest-    else if ind `isPrefixOf` line then-      (Code, line) : indented ind rest-    else-      maybe_code s+  indented _ [] = []+  indented ind s =+    let (line, rest) = getLine s+    in  if all isSpace line || (ind `isPrefixOf` line)+          then (Code, line) : indented ind rest+          else maybe_code s    -- Beginning of a code block.   r_code = rex "(.*)(::)([[:space:]]*)"

src/full/Agda/Syntax/Parser/LookAhead.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-| When lexing by hand (for instance string literals) we need to do some     looking ahead. The 'LookAhead' monad keeps track of the position we are@@ -43,7 +42,9 @@  -- | Throw an error message according to the supplied method. lookAheadError :: String -> LookAhead a-lookAheadError s = ($ s) =<< do LookAhead $ asks throwError+-- ASR (2021-02-07). The eta-expansion @\e -> throwError e@ is+-- required GHC >= 9.0.1 ((see Issue #4955).+lookAheadError s = ($ s) =<< do LookAhead $ asks (\e -> throwError e)  {--------------------------------------------------------------------------     Operations

src/full/Agda/Syntax/Parser/Monad.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.Syntax.Parser.Monad     ( -- * The parser monad@@ -8,7 +6,8 @@     , ParseState(..)     , ParseError(..), ParseWarning(..)     , LexState-    , LayoutContext(..)+    , LayoutBlock(..), LayoutContext, LayoutStatus(..)+    , Column     , ParseFlags (..)       -- * Running the parser     , initState@@ -22,31 +21,33 @@     , getParseFlags     , getLexState, pushLexState, popLexState       -- ** Layout-    , topContext, popContext, pushContext-    , pushCurrentContext+    , topBlock, popBlock, pushBlock+    , getContext, setContext, modifyContext+    , resetLayoutStatus       -- ** Errors-    , parseWarningName+    , parseWarning, parseWarningName     , parseError, parseErrorAt, parseError', parseErrorRange     , lexError     )     where -import Control.Exception (displayException)-import Data.Int--import Data.Data (Data)-+import Control.DeepSeq+import Control.Exception ( displayException )+import Control.Monad.Except import Control.Monad.State +import Data.Int+import Data.Data  ( Data )+import Data.Maybe ( listToMaybe )+ import Agda.Interaction.Options.Warnings  import Agda.Syntax.Position+import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ) ) -import Agda.Utils.Except ( MonadError(throwError) ) import Agda.Utils.FileName import Agda.Utils.List ( tailWithDefault ) import qualified Agda.Utils.Maybe.Strict as Strict- import Agda.Utils.Pretty  import Agda.Utils.Impossible@@ -68,10 +69,13 @@     , parseInp      :: String                -- ^ the current input     , parsePrevChar :: !Char                 -- ^ the character before the input     , parsePrevToken:: String                -- ^ the previous token-    , parseLayout   :: [LayoutContext]       -- ^ the stack of layout contexts+    , 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.     }     deriving Show @@ -81,13 +85,40 @@ -} type LexState = Int +-- | The stack of layout blocks.+--+--   When we encounter a layout keyword, we push a 'Tentative' block+--   with 'noColumn'.  This is replaced by aproper column once we+--   reach the next token.+type LayoutContext = [LayoutBlock]+ -- | We need to keep track of the context to do layout. The context---   specifies the indentation (if any) of a layout block. See+--   specifies the indentation columns of the open layout blocks. See --   "Agda.Syntax.Parser.Layout" for more informaton.-data LayoutContext  = NoLayout        -- ^ no layout-                    | Layout Int32    -- ^ layout at specified column+data LayoutBlock+  = Layout Keyword LayoutStatus Column+      -- ^ Layout at specified 'Column', introduced by 'Keyword'.     deriving Show +-- | A (layout) column.+type Column = Int32++-- | Status of a layout column (see #1145).+--   A layout column is 'Tentative' until we encounter a new line.+--   This allows stacking of layout keywords.+--+--   Inside a @LayoutContext@ the sequence of 'Confirmed' columns+--   needs to be strictly increasing.+--   'Tentative columns between 'Confirmed' columns need to be+--   strictly increasing as well.+data LayoutStatus+  = Tentative  -- ^ The token defining the layout column was on the same line+               --   as the layout keyword and we have not seen a new line yet.+  | Confirmed  -- ^ We have seen a new line since the layout keyword+               --   and the layout column has not been superseded by+               --   a smaller column.+    deriving (Eq, Show)+ -- | Parser flags. data ParseFlags = ParseFlags   { parseKeepComments :: Bool@@ -128,6 +159,7 @@     { errPath      :: !AbsolutePath     , errIOError   :: IOError     }+  deriving Show  -- | Warnings for parsing. data ParseWarning@@ -136,11 +168,22 @@     { warnRange    :: !(Range' SrcFile)                       -- ^ The range of the bigger overlapping token     }-  deriving Data+  | UnsupportedAttribute Range !(Maybe String)+    -- ^ Unsupported attribute.+  | MultipleAttributes Range !(Maybe String)+    -- ^ Multiple attributes.+  deriving (Data, Show) +instance NFData ParseWarning where+  rnf (OverlappingTokensWarning _) = ()+  rnf (UnsupportedAttribute _ s)   = rnf s+  rnf (MultipleAttributes _ s)     = rnf s+ parseWarningName :: ParseWarning -> WarningName parseWarningName = \case   OverlappingTokensWarning{} -> OverlappingTokensWarning_+  UnsupportedAttribute{}     -> UnsupportedAttribute_+  MultipleAttributes{}       -> MultipleAttributes_  -- | The result of parsing something. data ParseResult a@@ -166,13 +209,16 @@     , errMsg       = msg     } +-- | Records a warning.++parseWarning :: ParseWarning -> Parser ()+parseWarning w =+  modify' $ \s -> s { parseWarnings = w : parseWarnings s }+ {--------------------------------------------------------------------------     Instances  --------------------------------------------------------------------------} -instance Show ParseError where-  show = prettyShow- instance Pretty ParseError where   pretty ParseError{errPos,errSrcFile,errMsg,errPrevToken,errInput} = vcat       [ (pretty (errPos { srcFile = errSrcFile }) <> colon) <+>@@ -204,16 +250,28 @@     errPathRange = posToRange p p       where p = startPos $ Just $ errPath err -instance Show ParseWarning where-  show = prettyShow- instance Pretty ParseWarning where   pretty OverlappingTokensWarning{warnRange} = vcat       [ (pretty warnRange <> colon) <+>         "Multi-line comment spans one or more literate text blocks."       ]+  pretty (UnsupportedAttribute r s) = vcat+    [ (pretty r <> colon) <+>+      (case s of+         Nothing -> "Attributes"+         Just s  -> text s <+> "attributes") <+>+      "are not supported here."+    ]+  pretty (MultipleAttributes r s) = vcat+    [ (pretty r <> colon) <+>+      "Multiple" <+>+      maybe id (\s -> (text s <+>)) s "attributes (ignored)."+    ]+ instance HasRange ParseWarning where   getRange OverlappingTokensWarning{warnRange} = warnRange+  getRange (UnsupportedAttribute r _)          = r+  getRange (MultipleAttributes r _)            = r  {--------------------------------------------------------------------------     Running the parser@@ -228,8 +286,13 @@                 , parsePrevChar     = '\n'                 , parsePrevToken    = ""                 , parseLexState     = st-                , parseLayout       = [NoLayout]+                , parseLayout       = []        -- the first block will be from the top-level layout+                , parseLayStatus    = Confirmed -- for the to-be-determined column of the top-level layout+                , parseLayKw        = KwMutual  -- Layout keyword for the top-level layout.+                                                -- Does not mean that the top-level block is a mutual block.+                                                -- Just for better errors on stray @constructor@ decls.                 , parseFlags        = flags+                , parseWarnings     = []                 }   where   pos' = pos { srcFile = () }@@ -286,7 +349,7 @@   return $ posToInterval (parseSrcFile s) (parseLastPos s) (parsePos s)  getLexState :: Parser [LexState]-getLexState = parseLexState <$> get+getLexState = gets parseLexState  -- UNUSED Liang-Ting Chen 2019-07-16 --setLexState :: [LexState] -> Parser ()@@ -336,36 +399,29 @@     Layout  --------------------------------------------------------------------------} -getContext :: Parser [LayoutContext]+getContext :: MonadState ParseState m => m LayoutContext getContext = gets parseLayout -setContext :: [LayoutContext] -> Parser ()-setContext ctx = modify $ \ s -> s { parseLayout = ctx }+setContext :: LayoutContext -> Parser ()+setContext = modifyContext . const --- | Return the current layout context.-topContext :: Parser LayoutContext-topContext =-    do  ctx <- getContext-        case ctx of-            []  -> parseError "No layout context in scope"-            l:_ -> return l+modifyContext :: (LayoutContext -> LayoutContext) -> Parser ()+modifyContext f = modify $ \ s -> s { parseLayout = f (parseLayout s) } -popContext :: Parser ()-popContext =+-- | Return the current layout block.+topBlock :: Parser (Maybe LayoutBlock)+topBlock = listToMaybe <$> getContext++popBlock :: Parser ()+popBlock =     do  ctx <- getContext         case ctx of             []      -> parseError "There is no layout block to close at this point."             _:ctx   -> setContext ctx -pushContext :: LayoutContext -> Parser ()-pushContext l =-    do  ctx <- getContext-        setContext (l : ctx)+pushBlock :: LayoutBlock -> Parser ()+pushBlock l = modifyContext (l :) --- | Should only be used at the beginning of a file. When we start parsing---   we should be in layout mode. Instead of forcing zero indentation we use---   the indentation of the first token.-pushCurrentContext :: Parser ()-pushCurrentContext =-    do  p <- getLastPos-        pushContext (Layout (posCol p))+-- | When we see a layout keyword, by default we expect a 'Tentative' block.+resetLayoutStatus :: Parser ()+resetLayoutStatus = modify $ \ s -> s { parseLayStatus = Tentative }

src/full/Agda/Syntax/Parser/Parser.y view

@@ -1,2365 +1,2414 @@ {-{-# LANGUAGE PatternGuards #-}--{-| The parser is generated by Happy (<http://www.haskell.org/happy>).- -- - Ideally, ranges should be as precise as possible, to get messages that- - emphasize precisely the faulting term(s) upon error.- -- - However, interactive highlighting is only applied at the end of each- - mutual block, keywords are only highlighted once (see- - `TypeChecking.Rules.Decl'). So if the ranges of two declarations- - interleave, one must ensure that keyword ranges are not included in- - the intersection. (Otherwise they are uncolored by the interactive- - highlighting.)- -- -}-module Agda.Syntax.Parser.Parser (-      moduleParser-    , moduleNameParser-    , exprParser-    , exprWhereParser-    , tokensParser-    , holeContentParser-    , splitOnDots  -- only used by the internal test-suite-    ) where--import Control.Applicative ( (<|>) )-import Control.Monad--import Data.Bifunctor (first)-import Data.Char-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Traversable as T--import Debug.Trace--import Agda.Syntax.Position hiding (tests)-import Agda.Syntax.Parser.Monad-import Agda.Syntax.Parser.Lexer-import Agda.Syntax.Parser.Tokens-import Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Attribute-import Agda.Syntax.Concrete.Pattern-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Literal--import Agda.TypeChecking.Positivity.Occurrence hiding (tests)--import Agda.Utils.Either hiding (tests)-import Agda.Utils.Functor-import Agda.Utils.Hash-import Agda.Utils.List ( spanJust, chopWhen )-import Agda.Utils.Monad-import Agda.Utils.Pretty-import qualified Agda.Utils.Maybe.Strict as Strict--import Agda.Utils.Impossible--}--%name tokensParser Tokens-%name exprParser Expr-%name exprWhereParser ExprWhere-%name moduleParser File-%name moduleNameParser ModuleName-%name funclauseParser FunClause-%name holeContentParser HoleContent--%tokentype { Token }-%monad { Parser }-%lexer { lexer } { TokEOF{} }--%expect 9--- * shift/reduce for \ x y z -> foo = bar---   shifting means it'll parse as \ x y z -> (foo = bar) rather than---   (\ x y z -> foo) = bar------ * Telescope let and do-notation let.---      Expr2 -> 'let' Declarations . LetBody---      TypedBinding -> '(' 'let' Declarations . ')'---        ')'   shift, and enter state 486---              (reduce using rule 189)---   A do-block cannot end in a 'let' so committing to TypedBinding with a---   shift is the right thing to do here.------ * Named implicits in TypedBinding {x = y}. When encountering the '=' shift---   treats this as a named implicit and reducing would fail later.---- This is a trick to get rid of shift/reduce conflicts arising because we want--- to parse things like "m >>= \x -> k x". See the Expr rule for more--- information.-%nonassoc LOWEST-%nonassoc '->'--%token-    'abstract'                { TokKeyword KwAbstract $$ }-    'codata'                  { TokKeyword KwCoData $$ }-    'coinductive'             { TokKeyword KwCoInductive $$ }-    'constructor'             { TokKeyword KwConstructor $$ }-    'data'                    { TokKeyword KwData $$ }-    'eta-equality'            { TokKeyword KwEta $$ }-    'field'                   { TokKeyword KwField $$ }-    'forall'                  { TokKeyword KwForall $$ }-    'variable'                { TokKeyword KwVariable $$ }-    'hiding'                  { TokKeyword KwHiding $$ }-    'import'                  { TokKeyword KwImport $$ }-    'in'                      { TokKeyword KwIn $$ }-    'inductive'               { TokKeyword KwInductive $$ }-    'infix'                   { TokKeyword KwInfix $$ }-    'infixl'                  { TokKeyword KwInfixL $$ }-    'infixr'                  { TokKeyword KwInfixR $$ }-    'instance'                { TokKeyword KwInstance $$ }-    'overlap'                 { TokKeyword KwOverlap $$ }-    'let'                     { TokKeyword KwLet $$ }-    'macro'                   { TokKeyword KwMacro $$ }-    'module'                  { TokKeyword KwModule $$ }-    'mutual'                  { TokKeyword KwMutual $$ }-    'no-eta-equality'         { TokKeyword KwNoEta $$ }-    'open'                    { TokKeyword KwOpen $$ }-    'pattern'                 { TokKeyword KwPatternSyn $$ }-    'postulate'               { TokKeyword KwPostulate $$ }-    'primitive'               { TokKeyword KwPrimitive $$ }-    'private'                 { TokKeyword KwPrivate $$ }-    'Prop'                    { TokKeyword KwProp $$ }-    'public'                  { TokKeyword KwPublic $$ }-    'quote'                   { TokKeyword KwQuote $$ }-    'quoteTerm'               { TokKeyword KwQuoteTerm $$ }-    'record'                  { TokKeyword KwRecord $$ }-    'renaming'                { TokKeyword KwRenaming $$ }-    'rewrite'                 { TokKeyword KwRewrite $$ }-    'Set'                     { TokKeyword KwSet $$ }-    'syntax'                  { TokKeyword KwSyntax $$ }-    'tactic'                  { TokKeyword KwTactic $$ }-    'to'                      { TokKeyword KwTo $$ }-    'unquote'                 { TokKeyword KwUnquote $$ }-    'unquoteDecl'             { TokKeyword KwUnquoteDecl $$ }-    'unquoteDef'              { TokKeyword KwUnquoteDef $$ }-    'using'                   { TokKeyword KwUsing $$ }-    'where'                   { TokKeyword KwWhere $$ }-    'do'                      { TokKeyword KwDo $$ }-    'with'                    { TokKeyword KwWith $$ }--    'BUILTIN'                 { TokKeyword KwBUILTIN $$ }-    'CATCHALL'                { TokKeyword KwCATCHALL $$ }-    'DISPLAY'                 { TokKeyword KwDISPLAY $$ }-    'ETA'                     { TokKeyword KwETA $$ }-    'FOREIGN'                 { TokKeyword KwFOREIGN $$ }-    'COMPILE'                 { TokKeyword KwCOMPILE $$ }-    'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $$ }-    'INJECTIVE'               { TokKeyword KwINJECTIVE $$ }-    'INLINE'                  { TokKeyword KwINLINE $$ }-    'NOINLINE'                { TokKeyword KwNOINLINE $$ }-    'MEASURE'                 { TokKeyword KwMEASURE $$ }-    'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $$ }-    'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $$ }-    'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $$ }-    'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }-    'NON_COVERING'            { TokKeyword KwNON_COVERING $$ }-    'OPTIONS'                 { TokKeyword KwOPTIONS $$ }-    'POLARITY'                { TokKeyword KwPOLARITY $$ }-    'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $$ }-    'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $$ }-    'REWRITE'                 { TokKeyword KwREWRITE $$ }-    'STATIC'                  { TokKeyword KwSTATIC $$ }-    'TERMINATING'             { TokKeyword KwTERMINATING $$ }--    setN                      { TokSetN $$ }-    propN                     { TokPropN $$ }-    tex                       { TokTeX $$ }-    comment                   { TokComment $$ }--    '...'                     { TokSymbol SymEllipsis $$ }-    '..'                      { TokSymbol SymDotDot $$ }-    '.'                       { TokSymbol SymDot $$ }-    ';'                       { TokSymbol SymSemi $$ }-    ':'                       { TokSymbol SymColon $$ }-    '='                       { TokSymbol SymEqual $$ }-    '_'                       { TokSymbol SymUnderscore $$ }-    '?'                       { TokSymbol SymQuestionMark $$ }-    '->'                      { TokSymbol SymArrow $$ }-    '\\'                      { TokSymbol SymLambda $$ }-    '@'                       { TokSymbol SymAs $$ }-    '|'                       { TokSymbol SymBar $$ }-    '('                       { TokSymbol SymOpenParen $$ }-    ')'                       { TokSymbol SymCloseParen $$ }-    '(|'                      { TokSymbol SymOpenIdiomBracket $$ }-    '|)'                      { TokSymbol SymCloseIdiomBracket $$ }-    '(|)'                     { TokSymbol SymEmptyIdiomBracket $$ }-    '{{'                      { TokSymbol SymDoubleOpenBrace $$ }-    '}}'                      { TokSymbol SymDoubleCloseBrace $$ }-    '{'                       { TokSymbol SymOpenBrace $$ }-    '}'                       { TokSymbol SymCloseBrace $$ }---    ':{'                      { TokSymbol SymColonBrace $$ }-    vopen                     { TokSymbol SymOpenVirtualBrace $$ }-    vclose                    { TokSymbol SymCloseVirtualBrace $$ }-    vsemi                     { TokSymbol SymVirtualSemi $$ }-    '{-#'                     { TokSymbol SymOpenPragma $$ }-    '#-}'                     { TokSymbol SymClosePragma $$ }--    id                        { TokId $$ }-    q_id                      { TokQId $$ }--    string                    { TokString $$ }-    literal                   { TokLiteral $$ }--%%--{---------------------------------------------------------------------------    Parsing the token stream. Used by the TeX compiler.- --------------------------------------------------------------------------}---- Parse a list of tokens.-Tokens :: { [Token] }-Tokens : TokensR        { reverse $1 }---- Happy is much better at parsing left recursive grammars (constant--- stack size vs. linear stack size for right recursive).-TokensR :: { [Token] }-TokensR : TokensR Token { $2 : $1 }-        |               { [] }---- Parse single token.-Token :: { Token }-Token-      -- Please keep these keywords in alphabetical order!-    : 'abstract'                { TokKeyword KwAbstract $1 }-    | 'codata'                  { TokKeyword KwCoData $1 }-    | 'coinductive'             { TokKeyword KwCoInductive $1 }-    | 'constructor'             { TokKeyword KwConstructor $1 }-    | 'data'                    { TokKeyword KwData $1 }-    | 'do'                      { TokKeyword KwDo $1 }-    | 'eta-equality'            { TokKeyword KwEta $1 }-    | 'field'                   { TokKeyword KwField $1 }-    | 'forall'                  { TokKeyword KwForall $1 }-    | 'hiding'                  { TokKeyword KwHiding $1 }-    | 'import'                  { TokKeyword KwImport $1 }-    | 'in'                      { TokKeyword KwIn $1 }-    | 'inductive'               { TokKeyword KwInductive $1 }-    | 'infix'                   { TokKeyword KwInfix $1 }-    | 'infixl'                  { TokKeyword KwInfixL $1 }-    | 'infixr'                  { TokKeyword KwInfixR $1 }-    | 'instance'                { TokKeyword KwInstance $1 }-    | 'let'                     { TokKeyword KwLet $1 }-    | 'macro'                   { TokKeyword KwMacro $1 }-    | 'module'                  { TokKeyword KwModule $1 }-    | 'mutual'                  { TokKeyword KwMutual $1 }-    | 'no-eta-equality'         { TokKeyword KwNoEta $1 }-    | 'open'                    { TokKeyword KwOpen $1 }-    | 'overlap'                 { TokKeyword KwOverlap $1 }-    | 'pattern'                 { TokKeyword KwPatternSyn $1 }-    | 'postulate'               { TokKeyword KwPostulate $1 }-    | 'primitive'               { TokKeyword KwPrimitive $1 }-    | 'private'                 { TokKeyword KwPrivate $1 }-    | 'Prop'                    { TokKeyword KwProp $1 }-    | 'public'                  { TokKeyword KwPublic $1 }-    | 'quote'                   { TokKeyword KwQuote $1 }-    | 'quoteTerm'               { TokKeyword KwQuoteTerm $1 }-    | 'record'                  { TokKeyword KwRecord $1 }-    | 'renaming'                { TokKeyword KwRenaming $1 }-    | 'rewrite'                 { TokKeyword KwRewrite $1 }-    | 'Set'                     { TokKeyword KwSet $1 }-    | 'syntax'                  { TokKeyword KwSyntax $1 }-    | 'tactic'                  { TokKeyword KwTactic $1 }-    | 'to'                      { TokKeyword KwTo $1 }-    | 'unquote'                 { TokKeyword KwUnquote $1 }-    | 'unquoteDecl'             { TokKeyword KwUnquoteDecl $1 }-    | 'unquoteDef'              { TokKeyword KwUnquoteDef $1 }-    | 'using'                   { TokKeyword KwUsing $1 }-    | 'variable'                { TokKeyword KwVariable $1 }-    | 'where'                   { TokKeyword KwWhere $1 }-    | 'with'                    { TokKeyword KwWith $1 }--      -- Please keep these pragmas in alphabetical order!-    | 'BUILTIN'                 { TokKeyword KwBUILTIN $1 }-    | 'CATCHALL'                { TokKeyword KwCATCHALL $1 }-    | 'COMPILE'                 { TokKeyword KwCOMPILE $1 }-    | 'DISPLAY'                 { TokKeyword KwDISPLAY $1 }-    | 'ETA'                     { TokKeyword KwETA $1 }-    | 'FOREIGN'                 { TokKeyword KwFOREIGN $1 }-    | 'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $1 }-    | 'INJECTIVE'               { TokKeyword KwINJECTIVE $1 }-    | 'INLINE'                  { TokKeyword KwINLINE $1 }-    | 'MEASURE'                 { TokKeyword KwMEASURE $1 }-    | 'NOINLINE'                { TokKeyword KwNOINLINE $1 }-    | 'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $1 }-    | 'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $1 }-    | 'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $1 }-    | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }-    | 'NON_COVERING'            { TokKeyword KwNON_COVERING $1 }-    | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }-    | 'POLARITY'                { TokKeyword KwPOLARITY $1 }-    | 'REWRITE'                 { TokKeyword KwREWRITE $1 }-    | 'STATIC'                  { TokKeyword KwSTATIC $1 }-    | 'TERMINATING'             { TokKeyword KwTERMINATING $1 }-    | 'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $1 }-    | 'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $1 }--    | setN                      { TokSetN $1 }-    | propN                     { TokPropN $1 }-    | tex                       { TokTeX $1 }-    | comment                   { TokComment $1 }--    | '...'                     { TokSymbol SymEllipsis $1 }-    | '..'                      { TokSymbol SymDotDot $1 }-    | '.'                       { TokSymbol SymDot $1 }-    | ';'                       { TokSymbol SymSemi $1 }-    | ':'                       { TokSymbol SymColon $1 }-    | '='                       { TokSymbol SymEqual $1 }-    | '_'                       { TokSymbol SymUnderscore $1 }-    | '?'                       { TokSymbol SymQuestionMark $1 }-    | '->'                      { TokSymbol SymArrow $1 }-    | '\\'                      { TokSymbol SymLambda $1 }-    | '@'                       { TokSymbol SymAs $1 }-    | '|'                       { TokSymbol SymBar $1 }-    | '('                       { TokSymbol SymOpenParen $1 }-    | ')'                       { TokSymbol SymCloseParen $1 }-    | '(|'                      { TokSymbol SymOpenIdiomBracket $1 }-    | '|)'                      { TokSymbol SymCloseIdiomBracket $1 }-    | '(|)'                     { TokSymbol SymEmptyIdiomBracket $1 }-    | '{{'                      { TokSymbol SymDoubleOpenBrace $1 }-    | '}}'                      { TokSymbol SymDoubleCloseBrace $1 }-    | '{'                       { TokSymbol SymOpenBrace $1 }-    | '}'                       { TokSymbol SymCloseBrace $1 }-    | vopen                     { TokSymbol SymOpenVirtualBrace $1 }-    | vclose                    { TokSymbol SymCloseVirtualBrace $1 }-    | vsemi                     { TokSymbol SymVirtualSemi $1 }-    | '{-#'                     { TokSymbol SymOpenPragma $1 }-    | '#-}'                     { TokSymbol SymClosePragma $1 }--    | id                        { TokId $1 }-    | q_id                      { TokQId $1 }-    | string                    { TokString $1 }--    | literal                   { TokLiteral $1 }--{---------------------------------------------------------------------------    Top level- --------------------------------------------------------------------------}--File :: { ([Pragma], [Declaration]) }-File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }--maybe_vclose :: { () }-maybe_vclose : {- empty -} { () }-             | vclose      { () }--{---------------------------------------------------------------------------    Meta rules- --------------------------------------------------------------------------}---- The first token in a file decides the indentation of the top-level layout--- block. Or not. It will if we allow the top-level module to be omitted.--- topen :      {- empty -}     {% pushCurrentContext }---{-  A layout block might have to be closed by a parse error. Example:-        let x = e in e'-    Here the 'let' starts a layout block which should end before the 'in'.  The-    problem is that the lexer doesn't know this, so there is no virtual close-    brace. However when the parser sees the 'in' there will be a parse error.-    This is our cue to close the layout block.--}-close :: { () }-close : vclose  { () }-      | error   {% popContext }----- You can use concrete semi colons in a layout block started with a virtual--- brace, so we don't have to distinguish between the two semi colons. You can't--- use a virtual semi colon in a block started by a concrete brace, but this is--- simply because the lexer will not generate virtual semis in this case.-semi :: { Interval }-semi : ';'    { $1 }-     | vsemi  { $1 }----- Enter the 'imp_dir' lex state, where we can parse the keyword 'to'.-beginImpDir :: { () }-beginImpDir : {- empty -}   {% pushLexState imp_dir }--{---------------------------------------------------------------------------    Helper rules- --------------------------------------------------------------------------}---- A float. Used in fixity declarations.-Float :: { Ranged Double }-Float : literal {% case $1 of-                   { LitNat   r i -> return $ Ranged r $ fromInteger i-                   ; LitFloat r i -> return $ Ranged r i-                   ; _            -> parseError $ "Expected floating point number"-                   }-                }---{---------------------------------------------------------------------------    Names- --------------------------------------------------------------------------}---- A name is really a sequence of parts, but the lexer just sees it as a--- string, so we have to do the translation here.-Id :: { Name }-Id : id     {% mkName $1 }---- Space separated list of one or more identifiers.-SpaceIds :: { [Name] }-SpaceIds-    : Id SpaceIds { $1 : $2 }-    | Id          { [$1] }---- When looking for a double closed brace, we accept either a single token '}}'--- (which is what the unicode character "RIGHT WHITE CURLY BRACKET" is--- 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-  : '..' Id { setRelevance NonStrict $ defaultArg $2 }-  | '.'  Id { setRelevance Irrelevant $ defaultArg $2 }-  | Id      { defaultArg $1 }---- Space separated list of one or more possibly dotted identifiers.-MaybeDottedIds :: { [Arg Name] }-MaybeDottedIds-    : MaybeDottedId MaybeDottedIds { $1 : $2 }-    | MaybeDottedId                { [$1] }---- Space separated list of one or more identifiers, some of which may--- be surrounded by braces or dotted.-ArgIds :: { [Arg Name] }-ArgIds-    : MaybeDottedId ArgIds            { $1 : $2 }-    | MaybeDottedId                   { [$1] }-    | '{{' MaybeDottedIds DoubleCloseBrace ArgIds { map makeInstance $2 ++ $4 }-    | '{{' MaybeDottedIds DoubleCloseBrace        { map makeInstance $2 }-    | '{' MaybeDottedIds '}' ArgIds   { map hide $2 ++ $4 }-    | '{' MaybeDottedIds '}'          { map hide $2 }-    | '.' '{' SpaceIds '}' ArgIds     { map (hide . setRelevance Irrelevant . defaultArg) $3 ++ $5 }-    | '.' '{' SpaceIds '}'            { map (hide . setRelevance Irrelevant . defaultArg) $3 }-    | '.' '{{' SpaceIds DoubleCloseBrace ArgIds   { map (makeInstance . setRelevance Irrelevant . defaultArg) $3 ++ $5 }-    | '.' '{{' SpaceIds DoubleCloseBrace          { map (makeInstance . setRelevance Irrelevant . defaultArg) $3 }-    | '..' '{' SpaceIds '}' ArgIds    { map (hide . setRelevance NonStrict . defaultArg) $3 ++ $5 }-    | '..' '{' SpaceIds '}'           { map (hide . setRelevance NonStrict . defaultArg) $3 }-    | '..' '{{' SpaceIds DoubleCloseBrace ArgIds  { map (makeInstance . setRelevance NonStrict . defaultArg) $3 ++ $5 }-    | '..' '{{' SpaceIds DoubleCloseBrace         { map (makeInstance . setRelevance NonStrict . defaultArg) $3 }---- Modalities preceeding identifiers--ModalArgIds :: { ([Attr], [Arg Name]) }-ModalArgIds : Attributes ArgIds  {% ($1,) `fmap` mapM (applyAttrs $1) $2 }---- Attributes are parsed as '@' followed by an atomic expression.--Attribute :: { Attr }-Attribute : '@' ExprOrAttr  {% setRange (getRange ($1,$2)) `fmap` toAttribute $2 }---- Parse a reverse list of modalities--Attributes :: { [Attr] }-Attributes : {- empty -}  { [] }-  | Attributes Attribute { $2 : $1 }--Attributes1 :: { [Attr] }-Attributes1 : Attribute  { [$1] }-  | Attributes1 Attribute { $2 : $1 }--QId :: { QName }-QId : q_id  {% mkQName $1 }-    | Id    { QName $1 }----- A module name is just a qualified name-ModuleName :: { QName }-ModuleName : QId { $1 }----- A binding variable. Can be '_'-BId :: { Name }-BId : Id    { $1 }-    | '_'   { Name (getRange $1) InScope [Hole] }--{- UNUSED--- A binding variable. Can be '_'-MaybeDottedBId :: { (Relevance, Name) }-MaybeDottedBId-    : BId        { (Relevant  , $1) }-    | '.' BId    { (Irrelevant, $2) }-    | '..' BId   { (NonStrict, $2) }--}----- Space separated list of binding identifiers. Used in fixity--- declarations infixl 100 + --SpaceBIds :: { [Name] }-SpaceBIds-    : BId SpaceBIds { $1 : $2 }-    | BId           { [$1] }--{- DOES PRODUCE REDUCE/REDUCE CONFLICTS!--- Space-separated list of binding identifiers. Used in dependent--- function spaces: (x y z : Nat) -> ...--- (Used to be comma-separated; hence the name)--- QUESTION: Should this be replaced by SpaceBIds above?---CommaBIds :: { [(Relevance,Name)] }-CommaBIds :: { [Name] }-CommaBIds-    : CommaBIds BId { $1 ++ [$2] }  -- SWITCHING DOES NOT HELP-    | BId           { [$1] }--}---- Space-separated list of binding identifiers. Used in dependent--- function spaces: (x y z : Nat) -> ...--- (Used to be comma-separated; hence the name)--- QUESTION: Should this be replaced by SpaceBIds above?--- Andreas, 2011-04-07 the trick avoids reduce/reduce conflicts--- when parsing  (x y z : A) -> B--- at point (x y  it is not clear whether x y is an application or--- a variable list. We could be parsing (x y z) -> B--- with ((x y) z) being a type.-CommaBIds :: { [NamedArg Binder] }-CommaBIds : CommaBIdAndAbsurds {%-    case $1 of-      Left ns -> return ns-      Right _ -> parseError $ "expected sequence of bound identifiers, not absurd pattern"-    }--CommaBIdAndAbsurds :: { Either [NamedArg Binder] [Expr] }-CommaBIdAndAbsurds-  : Application {% boundNamesOrAbsurd $1 }-  | QId '=' QId {% (Left . pure . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Left $3) }-  | '_' '=' QId {% (Left . pure . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Left $3) }-  | QId '=' '_' {% (Left . pure . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Right $ getRange $3) }-  | '_' '=' '_' {% (Left . pure . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Right $ getRange $3) }---- Parse a sequence of identifiers, including hiding info.--- Does not include instance arguments.--- E.g. x {y z} _ {v}--- To be used in typed bindings, like (x {y z} _ {v} : Nat).-BIdsWithHiding :: { [NamedArg Binder] }-BIdsWithHiding : Application {%-  -- interpret an expression as a name and maybe a pattern-  case mapM exprAsNameOrHiddenNames $1 of-    Nothing   -> parseError "Expected sequence of possibly hidden bound identifiers"-    Just good -> forM (concat good) $ updateNamedArgA $ \ (n, me) -> do-                   p <- traverse exprToPattern me-                   pure $ Binder p (mkBoundName_ n)-    }----- Space separated list of strings in a pragma.-PragmaStrings :: { [String] }-PragmaStrings-    : {- empty -}           { [] }-    | string PragmaStrings  { snd $1 : $2 }-{- Unused-PragmaString :: { String }-PragmaString-    : string { snd $1 }--}-Strings :: { [(Interval, String)] }-Strings : {- empty -}    { [] }-        | string Strings { $1 : $2 }--ForeignCode :: { [(Interval, String)] }-ForeignCode-  : {- empty -} { [] }-  | string ForeignCode { $1 : $2 }-  | '{-#' ForeignCode '#-}' ForeignCode { [($1, "{-#")] ++ $2 ++ [($3, "#-}")] ++ $4 }--PragmaName :: { Name }-PragmaName : string {% mkName $1 }--PragmaQName :: { QName }-PragmaQName : string {% pragmaQName $1 }  -- Issue 2125. WAS: string {% fmap QName (mkName $1) }--PragmaQNames :: { [QName] }-PragmaQNames : Strings {% mapM pragmaQName $1 }--{---------------------------------------------------------------------------    Expressions (terms and types)- --------------------------------------------------------------------------}--{-  Expressions. You might expect lambdas and lets to appear in the first-    expression category (lowest precedence). The reason they don't is that we-    want to parse things like--        m >>= \x -> k x--    This will leads to a conflict in the following case--        m >>= \x -> k x >>= \y -> k' y--    At the second '>>=' we can either shift or reduce. We solve this problem-    using Happy's precedence directives. The rule 'Expr -> Expr1' (which is the-    rule you shouldn't use to reduce when seeing '>>=') is given LOWEST-    precedence.  The terminals '->' and op (which is what you should shift)-    is given higher precedence.--}---- Top level: Function types.-Expr :: { Expr }-Expr-  : TeleArrow Expr                      { Pi $1 $2 }-  | Application3 '->' Expr              { Fun (getRange ($1,$2,$3))-                                              (defaultArg $ rawAppUnlessSingleton (getRange $1) $1)-                                              $3 }-  | Attributes1 Application3 '->' Expr  {% applyAttrs $1 (defaultArg $ rawAppUnlessSingleton (getRange ($1,$2)) $2) <&> \ dom ->-                                             Fun (getRange ($1,$2,$3,$4)) dom $4 }-  | Expr1 '=' Expr                      { Equal (getRange ($1, $2, $3)) $1 $3 }-  | Expr1 %prec LOWEST                  { $1 }---- Level 1: Application-Expr1 :: { Expr }-Expr1  : WithExprs {% case $1 of-                      { [e]    -> return e-                      ; e : es -> return $ WithApp (fuseRange e es) e es-                      ; []     -> parseError "impossible: empty with expressions"-                      }-                   }--WithExprs :: { [Expr] }-WithExprs-  : Application3 '|' WithExprs { RawApp (getRange $1) $1 :  $3 }-  | Application                { [RawApp (getRange $1) $1] }--Application :: { [Expr] }-Application-    : Expr2             { [$1] }-    | Expr3 Application { $1 : $2 }---- Level 2: Lambdas and lets-Expr2 :: { Expr }-Expr2-    : '\\' LamBindings Expr        { Lam (getRange ($1,$2,$3)) $2 $3 }-    | 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 (getRange $2) $2) }--LetBody :: { Maybe Expr }-LetBody : 'in' Expr   { Just $2 }-        | {- empty -} { Nothing }--ExtendedOrAbsurdLam :: { Expr }-ExtendedOrAbsurdLam-    : '\\'  '{' LamClauses '}'     { ExtendedLam (getRange ($1,$2,$3,$4)) (reverse $3) }-    | '\\' 'where' vopen LamWhereClauses close { ExtendedLam (getRange ($1, $2, $4)) (reverse $4) }-    | '\\' AbsurdLamBindings       {% case $2 of-                                       Left (bs, h) -> if null bs then return $ AbsurdLam r h else-                                                       return $ Lam r bs (AbsurdLam r h)-                                                         where r = fuseRange $1 bs-                                       Right es -> do -- it is of the form @\ { p1 ... () }@-                                                     p <- exprToLHS (RawApp (getRange es) es);-                                                     return $ ExtendedLam (fuseRange $1 es)-                                                                     [LamClause (p [] []) AbsurdRHS NoWhere False]-                                   }--Application3 :: { [Expr] }-Application3-    : Expr3              { [$1] }-    | Expr3 Application3 { $1 : $2 }---- Christian Sattler, 2017-08-04, issue #2671--- We allow empty lists of expressions for the LHS of extended lambda clauses.--- I am not sure what Application3 is otherwise used for, so I keep the--- original type and create this copy solely for extended lambda clauses.-Application3PossiblyEmpty :: { [Expr] }-Application3PossiblyEmpty-    :                                 { [] }-    | Expr3 Application3PossiblyEmpty { $1 : $2 }---- Level 3: Atoms-Expr3Curly :: { Expr }-Expr3Curly-    : '{' Expr '}'                      {% HiddenArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }-    | '{' '}'                           { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }--Expr3NoCurly :: { Expr }-Expr3NoCurly-    : '?'                               { QuestionMark (getRange $1) Nothing }-    | '_'                               { Underscore (getRange $1) Nothing }-    | 'Prop'                            { Prop (getRange $1) }-    | 'Set'                             { Set (getRange $1) }-    | 'quote'                           { Quote (getRange $1) }-    | 'quoteTerm'                       { QuoteTerm (getRange $1) }-    | 'unquote'                         { Unquote (getRange $1) }-    | setN                              { SetN (getRange (fst $1)) (snd $1) }-    | propN                             { PropN (getRange (fst $1)) (snd $1) }-    | '{{' Expr DoubleCloseBrace        {% InstanceArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }-    | '(|' WithExprs '|)'               { IdiomBrackets (getRange ($1,$2,$3)) $2 }-    | '(|)'                             { IdiomBrackets (getRange $1) [] }-    | '(' ')'                           { Absurd (fuseRange $1 $2) }-    | '{{' DoubleCloseBrace             { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }-    | Id '@' Expr3                      { As (getRange ($1,$2,$3)) $1 $3 }-    | '.' Expr3                         { Dot (fuseRange $1 $2) $2 }-    | '..' Expr3                        { DoubleDot (fuseRange $1 $2) $2 }-    | 'record' '{' RecordAssignments '}' { Rec (getRange ($1,$2,$3,$4)) $3 }-    | 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (getRange ($1,$2,$3,$4,$5)) $2 $4 }-    | '...'                             { Ellipsis (getRange $1) }-    | ExprOrAttr                       { $1 }--ExprOrAttr :: { Expr }-ExprOrAttr-    : QId                               { Ident $1 }-    | literal                           { Lit $1 }-    | '(' Expr ')'                      { Paren (getRange ($1,$2,$3)) $2 }--Expr3 :: { Expr }-Expr3-    : Expr3Curly                        { $1 }-    | Expr3NoCurly                      { $1 }--RecordAssignments :: { RecordAssignments }-RecordAssignments-  : {- empty -}        { [] }-  | RecordAssignments1 { $1 }--RecordAssignments1 :: { RecordAssignments }-RecordAssignments1-  : RecordAssignment                        { [$1] }-  | RecordAssignment ';' RecordAssignments1 { $1 : $3 }--RecordAssignment :: { RecordAssignment }-RecordAssignment-  : FieldAssignment  { Left  $1 }-  | ModuleAssignment { Right $1 }--ModuleAssignment :: { ModuleAssignment }-ModuleAssignment-  : ModuleName OpenArgs ImportDirective  { ModuleAssignment $1 $2 $3 }--FieldAssignments :: { [FieldAssignment] }-FieldAssignments-  : {- empty -}       { [] }-  | FieldAssignments1 { $1 }--FieldAssignments1 :: { [FieldAssignment] }-FieldAssignments1-  : FieldAssignment                       { [$1] }-  | FieldAssignment ';' FieldAssignments1 { $1 : $3 }--FieldAssignment :: { FieldAssignment }-FieldAssignment-  : Id '=' Expr   { FieldAssignment $1 $3 }--{---------------------------------------------------------------------------    Bindings- --------------------------------------------------------------------------}---- "Delta ->" to avoid conflict between Delta -> Gamma and Delta -> A.-TeleArrow :: { Telescope }-TeleArrow : Telescope1 '->' { $1 }--Telescope1 :: { Telescope }-Telescope1 : TypedBindings { $1 }--TypedBindings :: { [TypedBinding] }-TypedBindings-    : TypedBinding TypedBindings { $1 : $2 }-    | TypedBinding               { [$1] }----- A typed binding is either (x1 .. xn : A) or   {y1 .. ym : B}--- Andreas, 2011-04-07: or  .(x1 .. xn : A) or  .{y1 .. ym : B}--- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B}-TypedBinding :: { TypedBinding }-TypedBinding-    : '.' '(' TBindWithHiding ')'    { setRange (getRange ($2,$3,$4)) $-                             setRelevance Irrelevant $3 }-    | '.' '{' TBind '}'    { setRange (getRange ($2,$3,$4)) $-                             setHiding Hidden $-                             setRelevance Irrelevant $3 }-    | '.' '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($2,$3,$4)) $-                             makeInstance $-                             setRelevance Irrelevant $3 }-    | '..' '(' TBindWithHiding ')'   { setRange (getRange ($2,$3,$4)) $-                             setRelevance NonStrict $3 }-    | '..' '{' TBind '}'   { setRange (getRange ($2,$3,$4)) $-                             setHiding Hidden $-                             setRelevance NonStrict $3 }-    | '..' '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($2,$3,$4)) $-                             makeInstance $-                             setRelevance NonStrict $3 }-    | '(' TBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }-    | '(' ModalTBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }-    | '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($1,$2,$3)) $-                             makeInstance $2 }-    | '{{' ModalTBind DoubleCloseBrace-                           { setRange (getRange ($1,$2,$3)) $-                             makeInstance $2 }-    | '{' TBind '}'        { setRange (getRange ($1,$2,$3)) $-                             setHiding Hidden $2 }-    | '{' ModalTBind '}'   { setRange (getRange ($1,$2,$3)) $-                             setHiding Hidden $2 }-    | '(' Open ')'               { TLet (getRange ($1,$3)) $2 }-    | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 }----- x1 .. xn : A--- x1 .. xn :{i1 i2 ..} A-TBind :: { TypedBinding }-TBind : CommaBIds ':' Expr  {-    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings-    in TBind r $1 $3-  }--ModalTBind :: { TypedBinding }-ModalTBind : Attributes1 CommaBIds ':' Expr  {% do-    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings-    xs <- mapM (applyAttrs $1 . setTacticAttr $1) $2-    return $ TBind r xs $4-  }---- x {y z} _ {v} : A-TBindWithHiding :: { TypedBinding }-TBindWithHiding : BIdsWithHiding ':' Expr  {-    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings-    in TBind r $1 $3-  }--ModalTBindWithHiding :: { TypedBinding }-ModalTBindWithHiding : Attributes1 BIdsWithHiding ':' Expr  {% do-    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings-    xs <- mapM (applyAttrs $1 . setTacticAttr $1) $2-    return $ TBind r xs $4-  }---- A non-empty sequence of lambda bindings.-LamBindings :: { [LamBinding] }-LamBindings-  : LamBinds '->' {%-      case reverse $1 of-        Left _ : _ -> parseError "Absurd lambda cannot have a body."-        _ : _      -> return [ b | Right b <- $1 ]-        []         -> parsePanic "Empty LamBinds"-      }--AbsurdLamBindings :: { Either ([LamBinding], Hiding) [Expr] }-AbsurdLamBindings-  : LamBindsAbsurd {%-    case $1 of-      Left lb -> case reverse lb of-                   Right _ : _ -> parseError "Missing body for lambda"-                   Left h  : _ -> return $ Left ([ b | Right b <- init lb], h)-                   _           -> parseError "Unsupported variant of lambda"-      Right es -> return $ Right es-    }---- absurd lambda is represented by @Left hiding@-LamBinds :: { [Either Hiding LamBinding] }-LamBinds-  : DomainFreeBinding LamBinds  { map Right $1 ++ $2 }-  | TypedBinding LamBinds       { Right (DomainFull $1) : $2 }-  | DomainFreeBinding           { map Right $1 }-  | TypedBinding                { [Right $ DomainFull $1] }-  | '(' ')'                     { [Left NotHidden] }-  | '{' '}'                     { [Left Hidden] }-  | '{{' DoubleCloseBrace       { [Left (Instance NoOverlap)] }---- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@-LamBindsAbsurd :: { Either [Either Hiding LamBinding] [Expr] }-LamBindsAbsurd-  : DomainFreeBinding LamBinds  { Left $ map Right $1 ++ $2 }-  | TypedBinding LamBinds       { Left $ Right (DomainFull $1) : $2 }-  | DomainFreeBindingAbsurd     { case $1 of-                                    Left lb -> Left $ map Right lb-                                    Right es -> Right es }-  | TypedBinding                { Left [Right $ DomainFull $1] }-  | '(' ')'                     { Left [Left NotHidden] }-  | '{' '}'                     { Left [Left Hidden] }-  | '{{' DoubleCloseBrace       { Left [Left (Instance NoOverlap)] }---- FNF, 2011-05-05: No where clauses in extended lambdas for now-NonAbsurdLamClause :: { LamClause }-NonAbsurdLamClause-  : Application3PossiblyEmpty '->' Expr {% do-      p <- exprToLHS (RawApp (getRange $1) $1) ;-      return LamClause{ lamLHS      = p [] []-                      , lamRHS      = RHS $3-                      , lamWhere    = NoWhere-                      , lamCatchAll = False }-        }-  | CatchallPragma Application3PossiblyEmpty '->' Expr {% do-      p <- exprToLHS (RawApp (getRange $2) $2) ;-      return LamClause{ lamLHS      = p [] []-                      , lamRHS      = RHS $4-                      , lamWhere    = NoWhere-                      , lamCatchAll = True }-        }--AbsurdLamClause :: { LamClause }-AbsurdLamClause--- FNF, 2011-05-09: By being more liberal here, we avoid shift/reduce and reduce/reduce errors.--- Later stages such as scope checking will complain if we let something through which we should not-  : Application {% do-      p <- exprToLHS (RawApp (getRange $1) $1);-      return LamClause{ lamLHS      = p [] []-                      , lamRHS      = AbsurdRHS-                      , lamWhere    = NoWhere-                      , lamCatchAll = False }-        }-  | CatchallPragma Application {% do-      p <- exprToLHS (RawApp (getRange $2) $2);-      return LamClause{ lamLHS      = p [] []-                      , lamRHS      = AbsurdRHS-                      , lamWhere    = NoWhere-                      , lamCatchAll = True }-        }--LamClause :: { LamClause }-LamClause-  : NonAbsurdLamClause { $1 }-  | AbsurdLamClause { $1 }---- Parses all extended lambda clauses except for a single absurd clause, which is taken care of--- in AbsurdLambda-LamClauses :: { [LamClause] }-LamClauses-   : LamClauses semi LamClause { $3 : $1 }-   | AbsurdLamClause semi LamClause { [$3, $1] }-   | NonAbsurdLamClause { [$1] }---   | {- empty -} { [] }---- Parses all extended lambda clauses including a single absurd clause. For λ--- where this is not taken care of in AbsurdLambda-LamWhereClauses :: { [LamClause] }-LamWhereClauses-   : LamWhereClauses semi LamClause { $3 : $1 }-   | LamClause { [$1] }--ForallBindings :: { [LamBinding] }-ForallBindings-  : TypedUntypedBindings1 '->' { $1 }---- A non-empty sequence of possibly untyped bindings.-TypedUntypedBindings1 :: { [LamBinding] }-TypedUntypedBindings1-  : DomainFreeBinding TypedUntypedBindings1 { $1 ++ $2 }-  | TypedBinding TypedUntypedBindings1      { DomainFull $1 : $2 }-  | DomainFreeBinding                       { $1 }-  | TypedBinding                            { [DomainFull $1] }---- A possibly empty sequence of possibly untyped bindings.--- This is used as telescope in data and record decls.-TypedUntypedBindings :: { [LamBinding] }-TypedUntypedBindings-  : DomainFreeBinding TypedUntypedBindings { $1 ++ $2 }-  | TypedBinding TypedUntypedBindings      { DomainFull $1 : $2 }-  |                                        { [] }---- A domain free binding is either x or {x1 .. xn}-DomainFreeBinding :: { [LamBinding] }-DomainFreeBinding-  : DomainFreeBindingAbsurd {% case $1 of-                             Left lbs -> return lbs-                             Right _ -> parseError "expected sequence of bound identifiers, not absurd pattern"-                          }--MaybeAsPattern :: { Maybe Pattern }-MaybeAsPattern-  : '@' Expr3   {% fmap Just (exprToPattern $2) }-  | {- empty -} { Nothing }---- A domain free binding is either x or {x1 .. xn}-DomainFreeBindingAbsurd :: { Either [LamBinding] [Expr]}-DomainFreeBindingAbsurd-    : BId      MaybeAsPattern { Left [mkDomainFree_ id $2 $1]  }-    | '.' BId  MaybeAsPattern { Left [mkDomainFree_ (setRelevance Irrelevant) $3 $2]  }-    | '..' BId MaybeAsPattern { Left [mkDomainFree_ (setRelevance NonStrict) $3 $2]  }-    | '(' Application ')'     {% exprToPattern (RawApp (getRange $2) $2) >>= \ p ->-                                 pure $ Left [mkDomainFree_ id (Just p) (Name noRange InScope [Hole])] }-    | '(' Attributes1 CommaBIdAndAbsurds ')'-         {% applyAttrs $2 defaultArgInfo <&> \ ai ->-              mapLeft (map (DomainFree . setTacticAttr $2 . setArgInfo ai)) $3 }-    | '{' CommaBIdAndAbsurds '}'-         { mapLeft (map (DomainFree . hide)) $2 }-    | '{' Attributes1 CommaBIdAndAbsurds '}'-         {% applyAttrs $2 defaultArgInfo <&> \ ai ->-              mapLeft (map (DomainFree . hide . setTacticAttr $2 . setArgInfo ai)) $3 }-    | '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree . makeInstance) $2 }-    | '{{' Attributes1 CommaBIds DoubleCloseBrace-         {% applyAttrs $2 defaultArgInfo <&> \ ai ->-              Left $ map (DomainFree . makeInstance . setTacticAttr $2 . setArgInfo ai) $3 }-    | '.' '{' CommaBIds '}' { Left $ map (DomainFree . hide . setRelevance Irrelevant) $3 }-    | '.' '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree . makeInstance . setRelevance Irrelevant) $3 }-    | '..' '{' CommaBIds '}' { Left $ map (DomainFree . hide . setRelevance NonStrict) $3 }-    | '..' '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree . makeInstance . setRelevance NonStrict) $3 }---{---------------------------------------------------------------------------    Do-notation- --------------------------------------------------------------------------}--DoStmts :: { [DoStmt] }-DoStmts : DoStmt              { [$1] }-        | DoStmt vsemi        { [$1] }    -- #3046-        | DoStmt semi DoStmts { $1 : $3 }--DoStmt :: { DoStmt }-DoStmt : Expr DoWhere {% buildDoStmt $1 $2 }--DoWhere :: { [LamClause] }-DoWhere-  : {- empty -} { [] }-  | 'where' vopen LamWhereClauses close { reverse $3 }--{---------------------------------------------------------------------------    Modules and imports- --------------------------------------------------------------------------}---- Import directives-ImportDirective :: { ImportDirective }-ImportDirective : ImportDirectives {% mergeImportDirectives $1 }--ImportDirectives :: { [ImportDirective] }-ImportDirectives-  : ImportDirective1 ImportDirectives { $1 : $2 }-  | {- empty -}                       { [] }--ImportDirective1 :: { ImportDirective }-  : 'public'      { defaultImportDir { importDirRange = getRange $1, publicOpen = Just (getRange $1) } }-  | Using         { defaultImportDir { importDirRange = snd $1, using    = fst $1 } }-  | Hiding        { defaultImportDir { importDirRange = snd $1, hiding   = fst $1 } }-  | RenamingDir   { defaultImportDir { importDirRange = snd $1, impRenaming = fst $1 } }--Using :: { (Using, Range) }-Using-    : 'using' '(' CommaImportNames ')'   { (Using $3 , getRange ($1,$2,$3,$4)) }-        -- using can have an empty list--Hiding :: { ([ImportedName], Range) }-Hiding-    : 'hiding' '(' CommaImportNames ')'  { ($3 , getRange ($1,$2,$3,$4)) }-        -- if you want to hide nothing that's fine, isn't it?--RenamingDir :: { ([Renaming] , Range) }-RenamingDir-    : 'renaming' '(' Renamings ')'      { ($3 , getRange ($1,$2,$3,$4)) }-    | 'renaming' '(' ')'                { ([] , getRange ($1,$2,$3)) }---- Renamings of the form 'x to y'-Renamings :: { [Renaming] }-Renamings-    : Renaming ';' Renamings    { $1 : $3 }-    | Renaming                  { [$1] }--Renaming :: { Renaming }-Renaming-    : ImportName_ 'to' RenamingTarget { Renaming $1 (setImportedName $1 (snd $3)) (fst $3) (getRange $2) }--RenamingTarget :: { (Maybe Fixity, Name) }-RenamingTarget-    : Id                 { (Nothing, $1) }-    | 'infix'  Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) NonAssoc)  , $3) }-    | 'infixl' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) LeftAssoc) , $3) }-    | 'infixr' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) RightAssoc), $3) }---- We need a special imported name here, since we have to trigger--- the imp_dir state exactly one token before the 'to'-ImportName_ :: { ImportedName }-ImportName_-    : beginImpDir Id          { ImportedName $2 }-    | 'module' beginImpDir Id { ImportedModule $3 }--ImportName :: { ImportedName }-ImportName : Id          { ImportedName $1 }-           | 'module' Id { ImportedModule $2 }---- Actually semi-colon separated-CommaImportNames :: { [ImportedName] }-CommaImportNames-    : {- empty -}       { [] }-    | CommaImportNames1 { $1 }--CommaImportNames1 :: { [ImportedName] }-CommaImportNames1-    : ImportName                        { [$1] }-    | ImportName ';' CommaImportNames1  { $1 : $3 }--{---------------------------------------------------------------------------    Function clauses- --------------------------------------------------------------------------}---- A left hand side of a function clause. We parse it as an expression, and--- then check that it is a valid left hand side.-LHS :: { LHS }-LHS : Expr1 WithRewriteExpressions-        {% exprToLHS $1      >>= \p ->-           buildWithBlock $2 >>= \ (rs, es) ->-           return (p rs $ map observeHiding es)-        }--WithRewriteExpressions :: { [Either RewriteEqn [Expr]] }-WithRewriteExpressions-  : {- empty -} { [] }-  | 'with' Expr1 WithRewriteExpressions-    {% fmap (++ $3) (buildWithStmt $2)  }-  | 'rewrite' Expr1 WithRewriteExpressions-    { Left (Rewrite $ fmap ((),) (fromWithApp $2)) : $3 }---- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@.-HoleContent :: { HoleContent }-HoleContent-  : Expr                   {  HoleContentExpr    $1 }-  | WithRewriteExpressions-    {% fmap HoleContentRewrite $ forM $1 $ \case-         Left r  -> pure r-         Right{} -> parseError "Cannot declare a 'with' abstraction from inside a hole."-      }---- Where clauses are optional.-WhereClause :: { WhereClause }-WhereClause-    : {- empty -}                      { NoWhere         }-    | 'where' Declarations0            { AnyWhere $2     }-    | 'module' Id 'where' Declarations0 { SomeWhere $2 PublicAccess $4 }-    | 'module' Underscore 'where' Declarations0 { SomeWhere $2 PublicAccess $4 }--ExprWhere :: { ExprWhere }-ExprWhere : Expr WhereClause { ExprWhere $1 $2 }--{---------------------------------------------------------------------------    Different kinds of declarations- --------------------------------------------------------------------------}---- Top-level definitions.-Declaration :: { [Declaration] }-Declaration-    : Fields        { [$1] }-    | FunClause     {  $1  }  -- includes type signatures-    | Data          { [$1] }-    | DataSig       { [$1] }  -- lone data type signature in mutual block-    | Record        { [$1] }-    | RecordSig     { [$1] }  -- lone record signature in mutual block-    | Infix         { [$1] }-    | Generalize    {  $1  }-    | Mutual        { [$1] }-    | Abstract      { [$1] }-    | Private       { [$1] }-    | Instance      { [$1] }-    | Macro         { [$1] }-    | Postulate     { [$1] }-    | Primitive     { [$1] }-    | Open          {  $1  }---    | Import      { [$1] }-    | ModuleMacro   { [$1] }-    | Module        { [$1] }-    | Pragma        { [$1] }-    | Syntax        { [$1] }-    | PatternSyn    { [$1] }-    | UnquoteDecl   { [$1] }---{---------------------------------------------------------------------------    Individual declarations- --------------------------------------------------------------------------}---- Type signatures of the form "n1 n2 n3 ... : Type", with at least--- one bound name.-TypeSigs :: { [Declaration] }-TypeSigs : SpaceIds ':' Expr { map (\ x -> typeSig defaultArgInfo Nothing x $3) $1 }---- A variant of TypeSigs where any sub-sequence of names can be marked--- as hidden or irrelevant using braces and dots:--- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type.-ArgTypeSigs :: { [Arg Declaration] }-ArgTypeSigs-  : ModalArgIds ':' Expr { let (attrs, xs) = $1 in-                           map (fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $3)) xs }-  | 'overlap' ModalArgIds ':' Expr {%-      let (attrs, 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 }-  | 'instance' ArgTypeSignatures {-    let-      setInstance (TypeSig info tac x t) = TypeSig (makeInstance info) tac x t-      setInstance _ = __IMPOSSIBLE__ in-    map (fmap setInstance) $2 }---- 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.-FunClause :: { [Declaration] }-FunClause : LHS RHS WhereClause {% funClauseOrTypeSigs [] $1 $2 $3 }-  | Attributes1 LHS RHS WhereClause {% funClauseOrTypeSigs $1 $2 $3 $4 }--RHS :: { RHSOrTypeSigs }-RHS : '=' Expr      { JustRHS (RHS $2) }-    | ':' Expr      { TypeSigsRHS $2 }-    | {- empty -}   { JustRHS AbsurdRHS }---- Data declaration. Can be local.-Data :: { Declaration }-Data : 'data' Id TypedUntypedBindings ':' Expr 'where'-            Declarations0       { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) $2 $3 $5 $7 }--  -- New cases when we already had a DataSig.  Then one can omit the sort.-     | 'data' Id TypedUntypedBindings 'where'-            Declarations0       { DataDef (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }---- Data type signature. Found in mutual blocks.-DataSig :: { Declaration }-DataSig : 'data' Id TypedUntypedBindings ':' Expr-  { DataSig (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }---- Andreas, 2012-03-16:  The Expr3NoCurly instead of Id in everything--- following 'record' is to remove the (harmless) shift/reduce conflict--- introduced by record update expressions.---- Record declarations.-Record :: { Declaration }-Record : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr 'where'-            RecordDeclarations-         {% exprToName $2 >>= \ n -> let ((x,y,z),ds) = $7 in return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7)) n x y z $3 $5 ds }-       | 'record' Expr3NoCurly TypedUntypedBindings 'where'-            RecordDeclarations-         {% exprToName $2 >>= \ n -> let ((x,y,z),ds) = $5 in return $ RecordDef (getRange ($1,$2,$3,$4,$5)) n x y z $3 ds }---- Record type signature. In mutual blocks.-RecordSig :: { Declaration }-RecordSig : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr-  {% exprToName $2 >>= \ n -> return $ RecordSig (getRange ($1,$2,$3,$4,$5)) n $3 $5 }---- Declaration of record constructor name.-RecordConstructorName :: { (Name, IsInstance) }-RecordConstructorName :                  'constructor' Id       { ($2, NotInstanceDef) }-                      | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (getRange $1)) }---- Fixity declarations.-Infix :: { Declaration }-Infix : 'infix'  Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) NonAssoc)   $3 }-      | 'infixl' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) LeftAssoc)  $3 }-      | 'infixr' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) RightAssoc) $3 }---- Field declarations.-Fields :: { Declaration }-Fields : 'field' ArgTypeSignaturesOrEmpty-            { let-                inst i = case getHiding i of-                           Instance _ -> InstanceDef noRange  -- no @instance@ keyword here-                           _          -> NotInstanceDef-                toField (Arg info (TypeSig info' tac x t)) = FieldSig (inst info') tac x (Arg info t)-              in Field (fuseRange $1 $2) $ map toField $2 }-  -- | 'field' ModalArgTypeSignatures-  --           { let-  --               inst i = case getHiding i of-  --                          Instance _ -> InstanceDef-  --                          _          -> NotInstanceDef-  --               toField (Arg info (TypeSig info' x t)) = FieldSig (inst info') x (Arg info t)-  --             in Field (fuseRange $1 $2) $ map toField $2 }---- 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 (fuseRange $1 $2) (map toGeneralize $2) ] }---- Mutually recursive declarations.-Mutual :: { Declaration }-Mutual : 'mutual' Declarations0  { Mutual (fuseRange $1 $2) $2 }----- Abstract declarations.-Abstract :: { Declaration }-Abstract : 'abstract' Declarations0  { Abstract (fuseRange $1 $2) $2 }----- Private can only appear on the top-level (or rather the module level).-Private :: { Declaration }-Private : 'private' Declarations0        { Private (fuseRange $1 $2) UserWritten $2 }----- Instance declarations.-Instance :: { Declaration }-Instance : 'instance' Declarations0  { InstanceB (getRange $1) $2 }----- Macro declarations.-Macro :: { Declaration }-Macro : 'macro' Declarations0 { Macro (fuseRange $1 $2) $2 }----- Postulates.-Postulate :: { Declaration }-Postulate : 'postulate' Declarations0 { Postulate (fuseRange $1 $2) $2 }---- Primitives. Can only contain type signatures.-Primitive :: { Declaration }-Primitive : 'primitive' TypeSignatures0  { Primitive (fuseRange $1 $2) $2 }---- Unquoting declarations.-UnquoteDecl :: { Declaration }-UnquoteDecl-  : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }-  | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) $2 $4 }-  | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) $2 $4 }---- Syntax declaration (To declare eg. mixfix binders)-Syntax :: { Declaration }-Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%-  case $2 of-    Name _ _ [_] -> case mkNotation $3 $5 of-      Left err -> parseError $ "Malformed syntax declaration: " ++ err-      Right n -> return $ Syntax $2 n-    _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"-}---- Pattern synonyms.-PatternSyn :: { Declaration }-PatternSyn : 'pattern' Id PatternSynArgs '=' Expr {% do-  p <- exprToPattern $5-  return (PatternSyn (getRange ($1,$2,$3,$4,$5)) $2 $3 p)-  }--PatternSynArgs :: { [Arg Name] }-PatternSynArgs-  : {- empty -} { [] }-  | LamBinds    {% patternSynArgs $1 }--SimpleIds :: { [RString] }-SimpleIds : SimpleId { [$1] }-          | SimpleIds SimpleId {$1 ++ [$2]}--HoleNames :: { [NamedArg HoleName] }-HoleNames : HoleName { [$1] }-          | HoleNames HoleName {$1 ++ [$2]}--HoleName :: { NamedArg HoleName }-HoleName-  : 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 }--SimpleTopHole :: { HoleName }-SimpleTopHole-  : SimpleId { ExprHole $1 }-  | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole $3 $5 }-  | '(' '\\' '_'      '->' SimpleId ')' { LambdaHole (Ranged (getRange $3) "_") $5 }--SimpleHole :: { HoleName }-SimpleHole-  : SimpleId { ExprHole $1 }-  | '\\' SimpleId '->' SimpleId { LambdaHole $2 $4 }-  | '\\' '_'      '->' SimpleId { LambdaHole (Ranged (getRange $3) "_") $4 }--- Variable name hole to be implemented later.---- Discard the interval.-SimpleId :: { RString }-SimpleId : id  { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) }--MaybeOpen :: { Maybe Range }-MaybeOpen : 'open'      { Just (getRange $1) }-          | {- empty -} { Nothing }---- Open-Open :: { [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 [ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show unique ]-    ; fresh' = Name mr NotInScope [ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show (unique + 1) ]-    ; impStm asR = Import r m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir-    ; appStm m' es =-        Private r Inserted-          [ ModuleMacro r m'-             (SectionApp (getRange es) []-               (RawApp (getRange es) (Ident (QName fresh) : es)))-             doOpen dir-          ]-    ; (initArgs, last2Args) = splitAt (length es - 2) es-    ; parseAsClause = case last2Args of-      { [ Ident (QName (Name asR 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 [Import r m Nothing doOpen dir]-      ; _ | Just (asR, m') <- parseAsClause ->-              if null initArgs then return-                 [ Import (getRange (m, asR, m', dir)) m-                     (Just (AsName m' asR)) doOpen dir-                 ]-              else return [ impStm asR, appStm (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 {-    let-    { m   = $2-    ; es  = $3-    ; dir = $4-    ; r   = getRange ($1, m, es, dir)-    } in-    [ case es of-      { []  -> Open r m dir-      ; _   -> Private r Inserted-                 [ ModuleMacro r (noName $ beginningOf $ getRange m)-                             (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))-                             DoOpen dir-                 ]-      }-    ]-  }-  | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {-    let r = getRange $2 in-    [ Private r Inserted-      [ ModuleMacro r (noName $ beginningOf $ getRange $2) (RecordModuleInstance r $2) DoOpen $6-      ]-    ]-  }--OpenArgs :: { [Expr] }-OpenArgs : {- empty -}    { [] }-         | Expr3 OpenArgs { $1 : $2 }--ModuleApplication :: { Telescope -> Parser ModuleApplication }-ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\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" )-                    }-                  | ModuleName OpenArgs {-                    (\ts -> return $ SectionApp (getRange ($1, $2)) ts (RawApp (fuseRange $1 $2) (Ident $1 : $2)) ) }----- Module instantiation-ModuleMacro :: { Declaration }-ModuleMacro : 'module' ModuleName TypedUntypedBindings '=' ModuleApplication ImportDirective-                    {% do { ma <- $5 (map addType $3)-                          ; name <- ensureUnqual $2-                          ; return $ ModuleMacro (getRange ($1, $2, ma, $6)) name ma DontOpen $6 } }-            | 'open' 'module' Id TypedUntypedBindings '=' ModuleApplication ImportDirective-                    {% do {ma <- $6 (map addType $4); return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) $3 ma DoOpen $7 } }---- Module-Module :: { Declaration }-Module : 'module' ModuleName TypedUntypedBindings 'where' Declarations0-                    { Module (getRange ($1,$2,$3,$4,$5)) $2 (map addType $3) $5 }-       | 'module' Underscore TypedUntypedBindings 'where' Declarations0-                    { Module (getRange ($1,$2,$3,$4,$5)) (QName $2) (map addType $3) $5 }--Underscore :: { Name }-Underscore : '_' { noName (getRange $1) }--TopLevel :: { [Declaration] }-TopLevel : TopDeclarations { figureOutTopLevelModule $1 }--Pragma :: { Declaration }-Pragma : DeclarationPragma  { Pragma $1 }--DeclarationPragma :: { Pragma }-DeclarationPragma-  : BuiltinPragma            { $1 }-  | RewritePragma            { $1 }-  | CompilePragma            { $1 }-  | ForeignPragma            { $1 }-  | StaticPragma             { $1 }-  | InjectivePragma          { $1 }-  | InlinePragma             { $1 }-  | NoInlinePragma           { $1 }-  | ImpossiblePragma         { $1 }-  | TerminatingPragma        { $1 }-  | NonTerminatingPragma     { $1 }-  | NoTerminationCheckPragma { $1 }-  | NonCoveringPragma        { $1 }-  | WarningOnUsagePragma     { $1 }-  | WarningOnImportPragma    { $1 }-  | MeasurePragma            { $1 }-  | CatchallPragma           { $1 }-  | DisplayPragma            { $1 }-  | EtaPragma                { $1 }-  | NoPositivityCheckPragma  { $1 }-  | NoUniverseCheckPragma    { $1 }-  | PolarityPragma           { $1 }-  | OptionsPragma            { $1 }-    -- Andreas, 2014-03-06-    -- OPTIONS pragma not allowed everywhere, but don't give parse error.-    -- Give better error during type checking instead.--OptionsPragma :: { Pragma }-OptionsPragma : '{-#' 'OPTIONS' PragmaStrings '#-}' { OptionsPragma (getRange ($1,$2,$4)) $3 }--BuiltinPragma :: { Pragma }-BuiltinPragma-    : '{-#' 'BUILTIN' string PragmaQName '#-}'-      { BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (mkRString $3) $4 }-    -- Extra rule to accept keyword REWRITE also as built-in:-    | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'-      { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) (Ranged (getRange $3) "REWRITE") $4 }--RewritePragma :: { Pragma }-RewritePragma-    : '{-#' 'REWRITE' PragmaQNames '#-}'-      { RewritePragma (getRange ($1,$2,$3,$4)) (getRange $2) $3 }--ForeignPragma :: { Pragma }-ForeignPragma-  : '{-#' 'FOREIGN' string ForeignCode '#-}' { ForeignPragma (getRange ($1, $2, fst $3, $5)) (mkRString $3) (recoverLayout $4) }--CompilePragma :: { Pragma }-CompilePragma-  : '{-#' 'COMPILE' string PragmaQName PragmaStrings '#-}'-    { CompilePragma (getRange ($1,$2,fst $3,$4,$6)) (mkRString $3) $4 (unwords $5) }--StaticPragma :: { Pragma }-StaticPragma-  : '{-#' 'STATIC' PragmaQName '#-}'-    { StaticPragma (getRange ($1,$2,$3,$4)) $3 }--InlinePragma :: { Pragma }-InlinePragma-  : '{-#' 'INLINE' PragmaQName '#-}'-    { InlinePragma (getRange ($1,$2,$3,$4)) True $3 }--NoInlinePragma :: { Pragma }-NoInlinePragma-  : '{-#' 'NOINLINE' PragmaQName '#-}'-    { InlinePragma (getRange ($1,$2,$3,$4)) False $3 }--InjectivePragma :: { Pragma }-InjectivePragma-  : '{-#' 'INJECTIVE' PragmaQName '#-}'-    { InjectivePragma (getRange ($1,$2,$3,$4)) $3 }--DisplayPragma :: { Pragma }-DisplayPragma-  : '{-#' 'DISPLAY' string PragmaStrings '#-}' {%-      let (r, s) = $3 in-      parseDisplayPragma (fuseRange $1 $5) (iStart r) (unwords (s : $4)) }--EtaPragma :: { Pragma }-EtaPragma-  : '{-#' 'ETA' PragmaQName '#-}'-    { EtaPragma (getRange ($1,$2,$3,$4)) $3 }--NoTerminationCheckPragma :: { Pragma }-NoTerminationCheckPragma-  : '{-#' 'NO_TERMINATION_CHECK' '#-}'-    { TerminationCheckPragma (getRange ($1,$2,$3)) NoTerminationCheck }--NonTerminatingPragma :: { Pragma }-NonTerminatingPragma-  : '{-#' 'NON_TERMINATING' '#-}'-    { TerminationCheckPragma (getRange ($1,$2,$3)) NonTerminating }--TerminatingPragma :: { Pragma }-TerminatingPragma-  : '{-#' 'TERMINATING' '#-}'-    { TerminationCheckPragma (getRange ($1,$2,$3)) Terminating }--NonCoveringPragma :: { Pragma }-NonCoveringPragma-  : '{-#' 'NON_COVERING' '#-}'-    { NoCoverageCheckPragma (getRange ($1,$2,$3)) }--MeasurePragma :: { Pragma }-MeasurePragma-  : '{-#' 'MEASURE' PragmaName '#-}'-    { let r = getRange ($1, $2, $3, $4) in-      TerminationCheckPragma r (TerminationMeasure r $3) }--CatchallPragma :: { Pragma }-CatchallPragma-  : '{-#' 'CATCHALL' '#-}'-    { CatchallPragma (getRange ($1,$2,$3)) }--ImpossiblePragma :: { Pragma }-ImpossiblePragma-  : '{-#' 'IMPOSSIBLE' '#-}'-    { ImpossiblePragma (getRange ($1,$2,$3)) }--NoPositivityCheckPragma :: { Pragma }-NoPositivityCheckPragma-  : '{-#' 'NO_POSITIVITY_CHECK' '#-}'-    { NoPositivityCheckPragma (getRange ($1,$2,$3)) }--NoUniverseCheckPragma :: { Pragma }-NoUniverseCheckPragma-  : '{-#' 'NO_UNIVERSE_CHECK' '#-}'-    { NoUniverseCheckPragma (getRange ($1,$2,$3)) }--PolarityPragma :: { Pragma }-PolarityPragma-  : '{-#' 'POLARITY' PragmaName Polarities '#-}'-    { let (rs, occs) = unzip (reverse $4) in-      PolarityPragma (getRange ($1,$2,$3,rs,$5)) $3 occs }--WarningOnUsagePragma :: { Pragma }-WarningOnUsagePragma-  : '{-#' 'WARNING_ON_USAGE' PragmaQName literal '#-}'-  {%  case $4 of-        { LitString r str -> return $ WarningOnUsage (getRange ($1,$2,$3,r,$5)) $3 str-        ; _ -> parseError "Expected string literal"-        }-  }--WarningOnImportPragma :: { Pragma }-WarningOnImportPragma-  : '{-#' 'WARNING_ON_IMPORT' literal '#-}'-  {%  case $3 of-        { LitString r str -> return $ WarningOnImport (getRange ($1,$2,r,$4)) str-        ; _ -> parseError "Expected string literal"-        }-  }---- Possibly empty list of polarities. Reversed.-Polarities :: { [(Range, Occurrence)] }-Polarities : {- empty -}          { [] }-           | Polarities Polarity  { $2 : $1 }--Polarity :: { (Range, Occurrence) }-Polarity : string {% polarity $1 }--{---------------------------------------------------------------------------    Sequences of declarations- --------------------------------------------------------------------------}---- Possibly empty list of type signatures, with several identifiers allowed--- for every signature.-TypeSignatures0 :: { [TypeSignature] }-TypeSignatures-    : vopen close    { [] }-    | TypeSignatures { $1 }---- Non-empty list of type signatures, with several identifiers allowed--- for every signature.-TypeSignatures :: { [TypeSignature] }-TypeSignatures-    : vopen TypeSignatures1 close   { reverse $2 }---- Inside the layout block.-TypeSignatures1 :: { [TypeSignature] }-TypeSignatures1-    : TypeSignatures1 semi TypeSigs { reverse $3 ++ $1 }-    | TypeSigs                      { reverse $1 }---- A variant of TypeSignatures which uses ArgTypeSigs instead of--- TypeSigs.-ArgTypeSignatures :: { [Arg TypeSignature] }-ArgTypeSignatures-    : vopen ArgTypeSignatures1 close   { reverse $2 }---- Inside the layout block.-ArgTypeSignatures1 :: { [Arg TypeSignature] }-ArgTypeSignatures1-    : ArgTypeSignatures1 semi ArgTypeSigs { reverse $3 ++ $1 }-    | ArgTypeSigs                         { reverse $1 }---- A variant of TypeSignatures which uses ArgTypeSigs instead of--- TypeSigs.-ArgTypeSignaturesOrEmpty :: { [Arg TypeSignature] }-ArgTypeSignaturesOrEmpty-    : vopen ArgTypeSignatures0 close   { reverse $2 }---- Inside the layout block.-ArgTypeSignatures0 :: { [Arg TypeSignature] }-ArgTypeSignatures0-    : ArgTypeSignatures0 semi ArgTypeSigs { reverse $3 ++ $1 }-    | ArgTypeSigs                         { reverse $1 }-    | {- empty -}                         { [] }---- -- A variant of TypeSignatures which uses ModalArgTypeSigs instead of--- -- TypeSigs.--- ModalArgTypeSignatures :: { [Arg TypeSignature] }--- ModalArgTypeSignatures---     : vopen ModalArgTypeSignatures1 close   { reverse $2 }---- -- Inside the layout block.--- ModalArgTypeSignatures1 :: { [Arg TypeSignature] }--- ModalArgTypeSignatures1---     : ModalArgTypeSignatures1 semi ModalArgTypeSigs { reverse $3 ++ $1 }---     | ModalArgTypeSigs                              { reverse $1 }---- Record declarations, including an optional record constructor name.-RecordDeclarations :: { ((Maybe (Ranged Induction), Maybe HasEta, Maybe (Name, IsInstance)), [Declaration]) }-RecordDeclarations-                                  : vopen RecordDirectives close {% ((,) `fmap` verifyRecordDirectives $2 <*> pure []) }-                                  | vopen RecordDirectives semi Declarations1 close {% ((,) `fmap` verifyRecordDirectives $2 <*> pure $4) }-                                  | vopen Declarations1 close {% ((,) `fmap` verifyRecordDirectives [] <*> pure $2)  }---RecordDirectives :: { [RecordDirective] }-RecordDirectives-                                  : { [] }-                                  | RecordDirectives semi RecordDirective { $3 : $1 }-                                  | RecordDirective { [$1] }--RecordDirective :: { RecordDirective }-RecordDirective-                                  : RecordConstructorName { Constructor $1 }-                                  | RecordInduction       { Induction $1 }-                                  | RecordEta             { Eta $1 }--RecordEta :: { Ranged HasEta }-RecordEta-                                  : 'eta-equality' { Ranged (getRange $1) YesEta }-                                  | 'no-eta-equality' { Ranged (getRange $1) NoEta }---- Declaration of record as 'inductive' or 'coinductive'.-RecordInduction :: { Ranged Induction }-RecordInduction-   : 'inductive'   { Ranged (getRange $1) Inductive   }-   | 'coinductive' { Ranged (getRange $1) CoInductive }---- Arbitrary declarations-Declarations :: { [Declaration] }-Declarations-    : vopen Declarations1 close { $2 }---- Arbitrary declarations (possibly empty)-Declarations0 :: { [Declaration] }-Declarations0-    : vopen close  { [] }-    | Declarations { $1 }--Declarations1 :: { [Declaration] }-Declarations1-    : Declaration semi Declarations1 { $1 ++ $3 }-    | Declaration vsemi              { $1 } -- #3046-    | Declaration                    { $1 }--TopDeclarations :: { [Declaration] }-TopDeclarations-  : {- empty -}   { [] }-  | Declarations1 { $1 }--{--{---------------------------------------------------------------------------    Parsers- --------------------------------------------------------------------------}---- | Parse the token stream. Used by the TeX compiler.-tokensParser :: Parser [Token]---- | Parse an expression. Could be used in interactions.-exprParser :: Parser Expr---- | Parse an expression followed by a where clause. Could be used in interactions.-exprWhereParser :: Parser ExprWhere---- | Parse a module.-moduleParser :: Parser Module---{---------------------------------------------------------------------------    Happy stuff- --------------------------------------------------------------------------}---- | Required by Happy.-happyError :: Parser a-happyError = parseError "Parse error"---{---------------------------------------------------------------------------    Utility functions- --------------------------------------------------------------------------}---- | Grab leading OPTIONS pragmas.-takeOptionsPragmas :: [Declaration] -> ([Pragma], [Declaration])-takeOptionsPragmas = spanJust $ \ d -> case d of-  Pragma p@OptionsPragma{} -> Just p-  _                        -> Nothing---- | Insert a top-level module if there is none.---   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.--    -- Case 1: Regular file layout: imports followed by one module. Nothing to do.-    (ds0, [ Module{} ]) -> ds--    -- 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 m tel [] : ds2) -> ds0 ++ [Module r m tel 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]--    -- 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 (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---- | Create a name from a string.--mkName :: (Interval, String) -> Parser Name-mkName (i, s) = do-    let xs = C.stringNameParts s-    mapM_ isValidId xs-    unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores"-    return $ Name (getRange i) InScope xs-    where-        isValidId Hole   = return ()-        isValidId (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-            ParseOk _ TokId{}  -> return ()-            ParseFailed{}      -> parseError err-            ParseOk _ TokEOF{} -> parseError err-            ParseOk _ t   -> parseError . ((err ++ " because it is ") ++) $ case t of-              TokId{}       -> __IMPOSSIBLE__-              TokQId{}      -> __IMPOSSIBLE__ -- "qualified"-              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"-                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        -> __IMPOSSIBLE__ -- "used for pragmas"-                SymClosePragma       -> __IMPOSSIBLE__ -- "used for pragmas"-                SymEllipsis          -> "used for function clauses"-                SymDotDot            -> __IMPOSSIBLE__ -- "a modality"-                SymEndComment        -> "the end-of-comment brace"-              TokString{}   -> __IMPOSSIBLE__-              TokSetN{}     -> "a type universe"-              TokPropN{}    -> "a prop universe"-              TokTeX{}      -> __IMPOSSIBLE__  -- used by the LaTeX backend only-              TokMarkup{}   -> __IMPOSSIBLE__  -- ditto-              TokComment{}  -> __IMPOSSIBLE__-              TokDummy{}    -> __IMPOSSIBLE__-              TokEOF{}      -> __IMPOSSIBLE__--        -- we know that there are no two Ids in a row-        alternating (Hole : Hole : _) = False-        alternating (_ : xs)          = alternating xs-        alternating []                = True---- | Create a qualified name from a list of strings-mkQName :: [(Interval, String)] -> Parser QName-mkQName ss = do-    xs <- mapM mkName ss-    return $ foldr Qual (QName $ last xs) (init xs)---- | Create a DomainFree binding from a name--mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> LamBinding-mkDomainFree_ f p n = DomainFree $ f $ defaultNamedArg $ Binder p $ mkBoundName_ n--mkRString :: (Interval, String) -> RString-mkRString (i, s) = Ranged (getRange i) s---- | Create a qualified name from a string (used in pragmas).---   Range of each name component is range of whole string.---   TODO: precise ranges!--pragmaQName :: (Interval, String) -> Parser QName-pragmaQName (r, s) = do-  let ss = chopWhen (== '.') s-  mkQName $ map (r,) ss--mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName)-mkNamedArg x y = do-  lbl <- case x of-           Nothing        -> return $ Just $ WithOrigin UserWritten $ unranged "_"-           Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x-           _              -> parseError "expected unqualified variable name"-  var <- case y of-           Left (QName y) -> return $ mkBoundName y noFixity'-           Right r        -> return $ mkBoundName (noName r) noFixity'-           _              -> parseError "expected unqualified variable name"-  return $ defaultArg $ Named lbl var---- | Polarity parser.--polarity :: (Interval, String) -> Parser (Range, Occurrence)-polarity (i, s) =-  case s of-    "_"  -> ret Unused-    "++" -> ret StrictPos-    "+"  -> ret JustPos-    "-"  -> ret JustNeg-    "*"  -> ret Mixed-    _    -> parseError $ "Not a valid polarity: " ++ s-  where-  ret x = return (getRange i, x)--recoverLayout :: [(Interval, String)] -> String-recoverLayout [] = ""-recoverLayout xs@((i, _) : _) = go (iStart i) xs-  where-    c0 = posCol (iStart i)--    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 }-      | l1 < l2  = genericReplicate (l2 - l1) '\n' ++ genericReplicate (max 0 (c2 - c0)) ' '-      | l1 == l2 = genericReplicate (c2 - c1) ' '--ensureUnqual :: QName -> Parser Name-ensureUnqual (QName x) = return x-ensureUnqual q@Qual{}  = parseError' (rStart' $ getRange q) "Qualified name not allowed here"---- | Match a particular name.-isName :: String -> (Interval, String) -> Parser ()-isName s (_,s')-    | s == s'   = return ()-    | otherwise = parseError $ "expected " ++ s ++ ", found " ++ s'---- | Build a forall pi (forall x y z -> ...)-forallPi :: [LamBinding] -> Expr -> Expr-forallPi bs e = Pi (map addType bs) e---- | Builds a 'RawApp' from 'Range' and 'Expr' list, unless the list--- is a single expression.  In the latter case, just the 'Expr' is--- returned.-rawAppUnlessSingleton :: Range -> [Expr] -> Expr-rawAppUnlessSingleton r = \case-  []  -> __IMPOSSIBLE__-  [e] -> e-  es  -> RawApp r es---- | Converts lambda bindings to typed bindings.-addType :: LamBinding -> TypedBinding-addType (DomainFull b) = b-addType (DomainFree x) = TBind r [x] $ Underscore r Nothing-  where r = getRange x---- | Interpret an expression as a list of names and (not parsed yet) as-patterns--exprAsTele :: Expr -> [Expr]-exprAsTele (RawApp _ es) = es-exprAsTele e             = [e]--exprAsNamesAndPatterns :: Expr -> Maybe [(Name, Maybe Expr)]-exprAsNamesAndPatterns = mapM exprAsNameAndPattern . exprAsTele--exprAsNameAndPattern :: Expr -> Maybe (Name, Maybe Expr)-exprAsNameAndPattern (Ident (QName x)) = Just (x, Nothing)-exprAsNameAndPattern (Underscore r _)  = Just (Name r InScope [Hole], Nothing)-exprAsNameAndPattern (As _ n e)        = Just (n, Just e)-exprAsNameAndPattern (Paren r e)       = Just (Name r InScope [Hole], Just e)-exprAsNameAndPattern _                 = Nothing---- interpret an expression as name or list of hidden / instance names-exprAsNameOrHiddenNames :: Expr -> Maybe [NamedArg (Name, Maybe Expr)]-exprAsNameOrHiddenNames t = case t of-  HiddenArg _ (Named Nothing e) -> do-    nps <- exprAsNamesAndPatterns e-    pure $ map (hide . defaultNamedArg) nps-  InstanceArg _ (Named Nothing e) -> do-    nps <- exprAsNamesAndPatterns e-    pure $ map (makeInstance . defaultNamedArg) nps-  e -> (pure . defaultNamedArg) `fmap` exprAsNameAndPattern e--boundNamesOrAbsurd :: [Expr] -> Parser (Either [NamedArg Binder] [Expr])-boundNamesOrAbsurd es-  | any isAbsurd es = return $ Right es-  | otherwise       =-    case mapM exprAsNameAndPattern es of-        Nothing   -> parseError $ "expected sequence of bound identifiers"-        Just good -> fmap Left $ forM good $ \ (n, me) -> do-                       p <- traverse exprToPattern me-                       return (defaultNamedArg (Binder p (mkBoundName_ n)))--  where--    isAbsurd :: Expr -> Bool-    isAbsurd (Absurd _)                  = True-    isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e-    isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e-    isAbsurd (Paren _ e)                 = isAbsurd e-    isAbsurd (As _ _ e)                  = isAbsurd e-    isAbsurd (RawApp _ es)               = any isAbsurd es-    isAbsurd _                           = False---- | Match a pattern-matching "assignment" statement @p <- e@-exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr))-exprToAssignment (RawApp r es)-  | (es1, arr : es2) <- break isLeftArrow es =-    case filter isLeftArrow es2 of-      arr : _ -> parseError' (rStart' $ getRange arr) $ "Unexpected " ++ prettyShow arr-      [] -> Just <$> ((,,) <$> exprToPattern (RawApp (getRange es1) es1)-                           <*> pure (getRange arr)-                           <*> pure (RawApp (getRange es2) es2))-  where-    isLeftArrow (Ident (QName (Name _ _ [Id arr]))) = arr `elem` ["<-", "←"]-    isLeftArrow _ = False-exprToAssignment _ = pure Nothing---- | Build a with-block-buildWithBlock :: [Either RewriteEqn [Expr]] -> Parser ([RewriteEqn], [Expr])-buildWithBlock rees = case groupByEither rees of-  (Left rs : rest) -> (rs,) <$> finalWith rest-  rest             -> ([],) <$> finalWith rest--  where--    finalWith :: [Either [RewriteEqn] [[Expr]]] -> Parser [Expr]-    finalWith []             = pure $ []-    finalWith [Right ees]    = pure $ concat ees-    finalWith (Right{} : tl) = parseError' (rStart' $ getRange tl)-      "Cannot use rewrite / pattern-matching with after a with-abstraction."---- | Build a with-statement-buildWithStmt :: Expr -> Parser [Either RewriteEqn [Expr]]-buildWithStmt e = do-  es <- mapM buildSingleWithStmt $ fromWithApp e-  let ees = groupByEither es-  pure $ map (mapLeft (Invert ())) ees--buildSingleWithStmt :: Expr -> Parser (Either (Pattern, Expr) Expr)-buildSingleWithStmt e = do-  mpatexpr <- exprToAssignment e-  pure $ case mpatexpr of-    Just (pat, _, expr) -> Left (pat, expr)-    Nothing             -> Right e--fromWithApp :: Expr -> [Expr]-fromWithApp = \case-  WithApp _ e es -> e : es-  e              -> [e]---- | Build a do-statement-defaultBuildDoStmt :: Expr -> [LamClause] -> Parser DoStmt-defaultBuildDoStmt e (_ : _) = parseError' (rStart' $ getRange e) "Only pattern matching do-statements can have where clauses."-defaultBuildDoStmt e []      = pure $ DoThen e--buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt-buildDoStmt (RawApp r [e])     cs = buildDoStmt e cs-buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds-buildDoStmt e@(RawApp r es)    cs = do-  mpatexpr <- exprToAssignment e-  case mpatexpr of-    Just (pat, r, expr) -> pure $ DoBind r pat expr cs-    Nothing -> defaultBuildDoStmt e cs-buildDoStmt e cs = defaultBuildDoStmt e cs---mergeImportDirectives :: [ImportDirective] -> Parser ImportDirective-mergeImportDirectives is = do-  i <- foldl merge (return defaultImportDir) is-  verifyImportDirective i-  where-    merge mi i2 = do-      i1 <- mi-      let err = parseError' (rStart' $ getRange i2) "Cannot mix using and hiding module directives"-      return $ ImportDirective-        { importDirRange = fuseRange i1 i2-        , using          = mappend (using i1) (using i2)-        , hiding         = hiding i1 ++ hiding i2-        , impRenaming    = impRenaming i1 ++ impRenaming i2-        , publicOpen     = publicOpen i1 <|> publicOpen i2 }---- | Check that an import directive doesn't contain repeated names-verifyImportDirective :: ImportDirective -> Parser ImportDirective-verifyImportDirective i =-    case filter ((>1) . length)-         $ group-         $ sort xs-    of-        []  -> return i-        yss -> parseErrorRange (head $ concat yss) $-                "Repeated name" ++ s ++ " in import directive: " ++-                concat (intersperse ", " $ map (prettyShow . head) yss)-            where-                s = case yss of-                        [_] -> ""-                        _   -> "s"-    where-        xs = names (using i) ++ hiding i ++ map renFrom (impRenaming i)-        names (Using xs)    = xs-        names UseEverything = []--data RecordDirective-   = Induction (Ranged Induction)-   | Constructor (Name, IsInstance)-   | Eta         (Ranged HasEta)-   deriving (Eq,Show)--verifyRecordDirectives :: [RecordDirective] -> Parser (Maybe (Ranged Induction), Maybe HasEta, Maybe (Name, IsInstance))-verifyRecordDirectives xs-  | null rs = return (ltm is, ltm es, ltm cs)-  | otherwise = parseErrorRange (head rs) $ "Repeated record directives at: \n" ++ intercalate "\n" (map prettyShow rs)- where-  ltm :: [a] -> Maybe a-  ltm [] = Nothing-  ltm (x:xs) = Just x-  errorFromList [] = []-  errorFromList [x] = []-  errorFromList xs = map getRange xs-  rs = sort (concat ([errorFromList is, errorFromList es', errorFromList cs]))-  is = [ i | Induction i <- xs ]-  es' = [ i | Eta i <- xs ]-  es = map rangedThing es'-  cs = [ i | Constructor i <- xs ]----- | Breaks up a string into substrings. Returns every maximal--- subsequence of zero or more characters distinct from @'.'@.------ > splitOnDots ""         == [""]--- > splitOnDots "foo.bar"  == ["foo", "bar"]--- > splitOnDots ".foo.bar" == ["", "foo", "bar"]--- > splitOnDots "foo.bar." == ["foo", "bar", ""]--- > splitOnDots "foo..bar" == ["foo", "", "bar"]-splitOnDots :: String -> [String]-splitOnDots ""        = [""]-splitOnDots ('.' : s) = [] : splitOnDots s-splitOnDots (c   : s) = case splitOnDots s of-  p : ps -> (c : p) : ps----- | Returns 'True' iff the name is a valid Haskell (hierarchical)--- module name.-validHaskellModuleName :: String -> Bool-validHaskellModuleName = all ok . splitOnDots-  where-  -- Checks if a dot-less module name is well-formed.-  ok :: String -> Bool-  ok []      = False-  ok (c : s) =-    isUpper c &&-    all (\c -> isLower c || c == '_' ||-               isUpper c ||-               generalCategory c == DecimalNumber ||-               c == '\'')-        s--{---------------------------------------------------------------------------    Patterns- --------------------------------------------------------------------------}---- | Turn an expression into a left hand side.-exprToLHS :: Expr -> Parser ([RewriteEqn] -> [WithHiding Expr] -> LHS)-exprToLHS e = (\e rwr wth -> LHS e rwr wth NoEllipsis) <$> exprToPattern e---- | Turn an expression into a pattern. Fails if the expression is not a---   valid pattern.-exprToPattern :: Expr -> Parser Pattern-exprToPattern e = case C.isPattern e of-  Nothing -> parseErrorRange e $ "Not a valid pattern: " ++ prettyShow e-  Just p  -> pure p--opAppExprToPattern :: OpApp Expr -> Parser Pattern-opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern"-opAppExprToPattern (Ordinary e) = exprToPattern e---- | Turn an expression into a name. Fails if the expression is not a---   valid identifier.-exprToName :: Expr -> Parser Name-exprToName (Ident (QName x)) = return x-exprToName e = parseErrorRange e $ "Not a valid identifier: " ++ prettyShow e--stripSingletonRawApp :: Expr -> Expr-stripSingletonRawApp (RawApp _ [e]) = stripSingletonRawApp e-stripSingletonRawApp e = e--isEqual :: Expr -> Maybe (Expr, Expr)-isEqual e =-  case stripSingletonRawApp e of-    Equal _ a b -> Just (stripSingletonRawApp a, stripSingletonRawApp b)-    _           -> Nothing---- | When given expression is @e1 = e2@, turn it into a named expression.---   Call this inside an implicit argument @{e}@ or @{{e}}@, where---   an equality must be a named argument (rather than a cubical partial match).-maybeNamed :: Expr -> Parser (Named_ Expr)-maybeNamed e =-  case isEqual e of-    Nothing       -> return $ unnamed e-    Just (e1, e2) -> do-      let succeed x = return $ named (WithOrigin UserWritten $ Ranged (getRange e1) x) e2-      case e1 of-        Ident (QName x) -> succeed $ nameToRawName x-        -- We could have the following, but names of arguments cannot be _.-        -- Underscore{}    -> succeed $ "_"-        _ -> parseErrorRange e $ "Not a valid named argument: " ++ prettyShow e--patternSynArgs :: [Either Hiding LamBinding] -> Parser [Arg Name]-patternSynArgs = mapM pSynArg-  where-    pSynArg Left{}                  = parseError "Absurd patterns are not allowed in pattern synonyms"-    pSynArg (Right DomainFull{})    = parseError "Unexpected type signature in pattern synonym argument"-    pSynArg (Right (DomainFree x))-      | let h = getHiding x, h `notElem` [Hidden, NotHidden]-         = parseError $ prettyShow h ++ " arguments not allowed to pattern synonyms"-      | not (isRelevant x) = parseError "Arguments to pattern synonyms must be relevant"-      | otherwise          = return $ fmap (boundName . binderName . namedThing) x--parsePanic s = parseError $ "Internal parser error: " ++ s ++ ". Please report this as a bug."--{- RHS or type signature -}--data RHSOrTypeSigs- = JustRHS RHS- | TypeSigsRHS Expr- deriving Show--patternToNames :: Pattern -> Parser [(ArgInfo, Name)]-patternToNames p =-  case p of-    IdentP (QName i)         -> return [(defaultArgInfo, i)]-    WildP r                  -> return [(defaultArgInfo, C.noName r)]-    DotP _ (Ident (QName i)) -> return [(setRelevance Irrelevant defaultArgInfo, i)]-    RawAppP _ ps             -> concat <$> mapM patternToNames ps-    _                        -> parseError $-      "Illegal name in type signature: " ++ prettyShow p--funClauseOrTypeSigs :: [Attr] -> LHS -> RHSOrTypeSigs -> WhereClause -> Parser [Declaration]-funClauseOrTypeSigs attrs lhs mrhs wh = do-  -- traceShowM lhs-  case mrhs of-    JustRHS rhs   -> do-      unless (null attrs) $ parseErrorRange attrs $ "A function clause cannot have attributes"-      return [FunClause lhs rhs wh False]-    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-          info <- applyAttrs attrs info-          return $ typeSig info (getTacticAttr attrs) x e-      _ -> parseError "A type signature cannot have a where clause"--parseDisplayPragma :: Range -> Position -> String -> 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) ->-      return $ DisplayPragma r lhs rhs-    _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."--typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration-typeSig i tac n e = TypeSig i tac n (Generalized e)---- * Attributes---- | Parsed attribute.--data Attr = Attr-  { attrRange :: Range       -- ^ Range includes the @.-  , attrName  :: String      -- ^ Concrete, user written attribute for error reporting.-  , theAttr   :: Attribute   -- ^ Parsed attribute.-  }--instance HasRange Attr where-  getRange = attrRange--instance SetRange Attr where-  setRange r (Attr _ x a) = Attr r x a---- | Parse an attribute.-toAttribute :: Expr -> Parser Attr-toAttribute x = maybe failure (return . Attr (getRange x) y) $ exprToAttribute x-  where-  y = prettyShow x-  failure = parseErrorRange x $ "Unknown attribute: " ++ y---- | 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.-applyAttr :: (LensAttribute a) => Attr -> a -> Parser a-applyAttr attr@(Attr r x a) = maybe failure return . setPristineAttribute a-  where-  failure = errorConflictingAttribute attr---- | 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-  checkForUniqueAttribute (isJust . isQuantityAttribute ) attrs-  checkForUniqueAttribute (isJust . isRelevanceAttribute) attrs-  checkForUniqueAttribute (isJust . isTacticAttribute)    attrs-  foldM (flip applyAttr) arg attrs---- | Set the tactic attribute of a binder-setTacticAttr :: [Attr] -> NamedArg Binder -> NamedArg Binder-setTacticAttr as = updateNamedArg $ fmap $ \ b ->-  case getTacticAttr as of+#if  __GLASGOW_HASKELL__ > 800+{-# OPTIONS_GHC -Wno-error=missing-signatures #-}+#endif+{-# LANGUAGE PatternGuards #-}++{-| The parser is generated by Happy (<http://www.haskell.org/happy>).+ -+ - Ideally, ranges should be as precise as possible, to get messages that+ - emphasize precisely the faulting term(s) upon error.+ -+ - However, interactive highlighting is only applied at the end of each+ - mutual block, keywords are only highlighted once (see+ - `TypeChecking.Rules.Decl'). So if the ranges of two declarations+ - interleave, one must ensure that keyword ranges are not included in+ - the intersection. (Otherwise they are uncolored by the interactive+ - highlighting.)+ -+ -}+module Agda.Syntax.Parser.Parser (+      moduleParser+    , moduleNameParser+    , exprParser+    , exprWhereParser+    , tokensParser+    , holeContentParser+    , splitOnDots  -- only used by the internal test-suite+    ) where++import Prelude hiding ( null )++import Control.Applicative ( (<|>) )+import Control.Monad++import Data.Bifunctor (first, second)+import Data.Char+import qualified Data.List as List+import Data.Maybe+import Data.Semigroup ((<>), sconcat)+import qualified Data.Traversable as T++import Agda.Syntax.Position hiding (tests)+import Agda.Syntax.Parser.Monad+import Agda.Syntax.Parser.Lexer+import Agda.Syntax.Parser.Tokens+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Common+import Agda.Syntax.Notation+import Agda.Syntax.Literal++import Agda.TypeChecking.Positivity.Occurrence hiding (tests)++import Agda.Utils.Either hiding (tests)+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.List ( spanJust, chopWhen )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Pretty hiding ((<>))+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++}++%name tokensParser Tokens+%name exprParser Expr+%name exprWhereParser ExprWhere+%name moduleParser File+%name moduleNameParser ModuleName+%name funclauseParser FunClause+%name holeContentParser HoleContent++%tokentype { Token }+%monad { Parser }+%lexer { lexer } { TokEOF{} }++%expect 8+-- * shift/reduce for \ x y z -> foo = bar+--   shifting means it'll parse as \ x y z -> (foo = bar) rather than+--   (\ x y z -> foo) = bar+--+-- * Telescope let and do-notation let.+--      Expr2 -> 'let' Declarations . LetBody+--      TypedBinding -> '(' 'let' Declarations . ')'+--        ')'   shift, and enter state 486+--              (reduce using rule 189)+--   A do-block cannot end in a 'let' so committing to TypedBinding with a+--   shift is the right thing to do here.+--+-- * Named implicits in TypedBinding {x = y}. When encountering the '=' shift+--   treats this as a named implicit and reducing would fail later.++-- This is a trick to get rid of shift/reduce conflicts arising because we want+-- to parse things like "m >>= \x -> k x". See the Expr rule for more+-- information.+%nonassoc LOWEST+%nonassoc '->'++%token+    'abstract'                { TokKeyword KwAbstract $$ }+    'codata'                  { TokKeyword KwCoData $$ }+    'coinductive'             { TokKeyword KwCoInductive $$ }+    'constructor'             { TokKeyword KwConstructor $$ }+    'data'                    { TokKeyword KwData $$ }+    'eta-equality'            { TokKeyword KwEta $$ }+    'field'                   { TokKeyword KwField $$ }+    'forall'                  { TokKeyword KwForall $$ }+    'variable'                { TokKeyword KwVariable $$ }+    'hiding'                  { TokKeyword KwHiding $$ }+    'import'                  { TokKeyword KwImport $$ }+    'in'                      { TokKeyword KwIn $$ }+    'inductive'               { TokKeyword KwInductive $$ }+    'infix'                   { TokKeyword KwInfix $$ }+    'infixl'                  { TokKeyword KwInfixL $$ }+    'infixr'                  { TokKeyword KwInfixR $$ }+    'instance'                { TokKeyword KwInstance $$ }+    'overlap'                 { TokKeyword KwOverlap $$ }+    'let'                     { TokKeyword KwLet $$ }+    'macro'                   { TokKeyword KwMacro $$ }+    'module'                  { TokKeyword KwModule $$ }+    'interleaved'             { TokKeyword KwInterleaved $$ }+    'mutual'                  { TokKeyword KwMutual $$ }+    'no-eta-equality'         { TokKeyword KwNoEta $$ }+    'open'                    { TokKeyword KwOpen $$ }+    'pattern'                 { TokKeyword KwPatternSyn $$ }+    'postulate'               { TokKeyword KwPostulate $$ }+    'primitive'               { TokKeyword KwPrimitive $$ }+    'private'                 { TokKeyword KwPrivate $$ }+    'public'                  { TokKeyword KwPublic $$ }+    'quote'                   { TokKeyword KwQuote $$ }+    'quoteTerm'               { TokKeyword KwQuoteTerm $$ }+    'record'                  { TokKeyword KwRecord $$ }+    'renaming'                { TokKeyword KwRenaming $$ }+    'rewrite'                 { TokKeyword KwRewrite $$ }+    'syntax'                  { TokKeyword KwSyntax $$ }+    'tactic'                  { TokKeyword KwTactic $$ }+    'to'                      { TokKeyword KwTo $$ }+    'unquote'                 { TokKeyword KwUnquote $$ }+    'unquoteDecl'             { TokKeyword KwUnquoteDecl $$ }+    'unquoteDef'              { TokKeyword KwUnquoteDef $$ }+    'using'                   { TokKeyword KwUsing $$ }+    'where'                   { TokKeyword KwWhere $$ }+    'do'                      { TokKeyword KwDo $$ }+    'with'                    { TokKeyword KwWith $$ }++    'BUILTIN'                 { TokKeyword KwBUILTIN $$ }+    'CATCHALL'                { TokKeyword KwCATCHALL $$ }+    'DISPLAY'                 { TokKeyword KwDISPLAY $$ }+    'ETA'                     { TokKeyword KwETA $$ }+    'FOREIGN'                 { TokKeyword KwFOREIGN $$ }+    'COMPILE'                 { TokKeyword KwCOMPILE $$ }+    'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $$ }+    'INJECTIVE'               { TokKeyword KwINJECTIVE $$ }+    'INLINE'                  { TokKeyword KwINLINE $$ }+    'NOINLINE'                { TokKeyword KwNOINLINE $$ }+    'MEASURE'                 { TokKeyword KwMEASURE $$ }+    'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $$ }+    'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $$ }+    'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $$ }+    'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }+    'NON_COVERING'            { TokKeyword KwNON_COVERING $$ }+    'OPTIONS'                 { TokKeyword KwOPTIONS $$ }+    'POLARITY'                { TokKeyword KwPOLARITY $$ }+    'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $$ }+    'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $$ }+    'REWRITE'                 { TokKeyword KwREWRITE $$ }+    'STATIC'                  { TokKeyword KwSTATIC $$ }+    'TERMINATING'             { TokKeyword KwTERMINATING $$ }++    tex                       { TokTeX $$ }+    comment                   { TokComment $$ }++    '...'                     { TokSymbol SymEllipsis $$ }+    '..'                      { TokSymbol SymDotDot $$ }+    '.'                       { TokSymbol SymDot $$ }+    ';'                       { TokSymbol SymSemi $$ }+    ':'                       { TokSymbol SymColon $$ }+    '='                       { TokSymbol SymEqual $$ }+    '_'                       { TokSymbol SymUnderscore $$ }+    '?'                       { TokSymbol SymQuestionMark $$ }+    '->'                      { TokSymbol SymArrow $$ }+    '\\'                      { TokSymbol SymLambda $$ }+    '@'                       { TokSymbol SymAs $$ }+    '|'                       { TokSymbol SymBar $$ }+    '('                       { TokSymbol SymOpenParen $$ }+    ')'                       { TokSymbol SymCloseParen $$ }+    '(|'                      { TokSymbol SymOpenIdiomBracket $$ }+    '|)'                      { TokSymbol SymCloseIdiomBracket $$ }+    '(|)'                     { TokSymbol SymEmptyIdiomBracket $$ }+    '{{'                      { TokSymbol SymDoubleOpenBrace $$ }+    '}}'                      { TokSymbol SymDoubleCloseBrace $$ }+    '{'                       { TokSymbol SymOpenBrace $$ }+    '}'                       { TokSymbol SymCloseBrace $$ }+--    ':{'                      { TokSymbol SymColonBrace $$ }+    vopen                     { TokSymbol SymOpenVirtualBrace $$ }+    vclose                    { TokSymbol SymCloseVirtualBrace $$ }+    vsemi                     { TokSymbol SymVirtualSemi $$ }+    '{-#'                     { TokSymbol SymOpenPragma $$ }+    '#-}'                     { TokSymbol SymClosePragma $$ }++    id                        { TokId $$ }+    q_id                      { TokQId $$ }++    string                    { TokString $$ }+    literal                   { TokLiteral $$ }++%%++{--------------------------------------------------------------------------+    Parsing the token stream. Used by the TeX compiler.+ --------------------------------------------------------------------------}++-- Parse a list of tokens.+Tokens :: { [Token] }+Tokens : TokensR        { reverse $1 }++-- Happy is much better at parsing left recursive grammars (constant+-- stack size vs. linear stack size for right recursive).+TokensR :: { [Token] }+TokensR : TokensR Token { $2 : $1 }+        |               { [] }++-- Parse single token.+Token :: { Token }+Token+      -- Please keep these keywords in alphabetical order!+    : 'abstract'                { TokKeyword KwAbstract $1 }+    | 'codata'                  { TokKeyword KwCoData $1 }+    | 'coinductive'             { TokKeyword KwCoInductive $1 }+    | 'constructor'             { TokKeyword KwConstructor $1 }+    | 'data'                    { TokKeyword KwData $1 }+    | 'do'                      { TokKeyword KwDo $1 }+    | 'eta-equality'            { TokKeyword KwEta $1 }+    | 'field'                   { TokKeyword KwField $1 }+    | 'forall'                  { TokKeyword KwForall $1 }+    | 'hiding'                  { TokKeyword KwHiding $1 }+    | 'import'                  { TokKeyword KwImport $1 }+    | 'in'                      { TokKeyword KwIn $1 }+    | 'inductive'               { TokKeyword KwInductive $1 }+    | 'infix'                   { TokKeyword KwInfix $1 }+    | 'infixl'                  { TokKeyword KwInfixL $1 }+    | 'infixr'                  { TokKeyword KwInfixR $1 }+    | 'instance'                { TokKeyword KwInstance $1 }+    | 'let'                     { TokKeyword KwLet $1 }+    | 'macro'                   { TokKeyword KwMacro $1 }+    | 'module'                  { TokKeyword KwModule $1 }+    | 'interleaved'             { TokKeyword KwInterleaved $1 }+    | 'mutual'                  { TokKeyword KwMutual $1 }+    | 'no-eta-equality'         { TokKeyword KwNoEta $1 }+    | 'open'                    { TokKeyword KwOpen $1 }+    | 'overlap'                 { TokKeyword KwOverlap $1 }+    | 'pattern'                 { TokKeyword KwPatternSyn $1 }+    | 'postulate'               { TokKeyword KwPostulate $1 }+    | 'primitive'               { TokKeyword KwPrimitive $1 }+    | 'private'                 { TokKeyword KwPrivate $1 }+    | 'public'                  { TokKeyword KwPublic $1 }+    | 'quote'                   { TokKeyword KwQuote $1 }+    | 'quoteTerm'               { TokKeyword KwQuoteTerm $1 }+    | 'record'                  { TokKeyword KwRecord $1 }+    | 'renaming'                { TokKeyword KwRenaming $1 }+    | 'rewrite'                 { TokKeyword KwRewrite $1 }+    | 'syntax'                  { TokKeyword KwSyntax $1 }+    | 'tactic'                  { TokKeyword KwTactic $1 }+    | 'to'                      { TokKeyword KwTo $1 }+    | 'unquote'                 { TokKeyword KwUnquote $1 }+    | 'unquoteDecl'             { TokKeyword KwUnquoteDecl $1 }+    | 'unquoteDef'              { TokKeyword KwUnquoteDef $1 }+    | 'using'                   { TokKeyword KwUsing $1 }+    | 'variable'                { TokKeyword KwVariable $1 }+    | 'where'                   { TokKeyword KwWhere $1 }+    | 'with'                    { TokKeyword KwWith $1 }++      -- Please keep these pragmas in alphabetical order!+    | 'BUILTIN'                 { TokKeyword KwBUILTIN $1 }+    | 'CATCHALL'                { TokKeyword KwCATCHALL $1 }+    | 'COMPILE'                 { TokKeyword KwCOMPILE $1 }+    | 'DISPLAY'                 { TokKeyword KwDISPLAY $1 }+    | 'ETA'                     { TokKeyword KwETA $1 }+    | 'FOREIGN'                 { TokKeyword KwFOREIGN $1 }+    | 'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $1 }+    | 'INJECTIVE'               { TokKeyword KwINJECTIVE $1 }+    | 'INLINE'                  { TokKeyword KwINLINE $1 }+    | 'MEASURE'                 { TokKeyword KwMEASURE $1 }+    | 'NOINLINE'                { TokKeyword KwNOINLINE $1 }+    | 'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $1 }+    | 'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $1 }+    | 'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $1 }+    | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }+    | 'NON_COVERING'            { TokKeyword KwNON_COVERING $1 }+    | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }+    | 'POLARITY'                { TokKeyword KwPOLARITY $1 }+    | 'REWRITE'                 { TokKeyword KwREWRITE $1 }+    | 'STATIC'                  { TokKeyword KwSTATIC $1 }+    | 'TERMINATING'             { TokKeyword KwTERMINATING $1 }+    | 'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $1 }+    | 'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $1 }++    | tex                       { TokTeX $1 }+    | comment                   { TokComment $1 }++    | '...'                     { TokSymbol SymEllipsis $1 }+    | '..'                      { TokSymbol SymDotDot $1 }+    | '.'                       { TokSymbol SymDot $1 }+    | ';'                       { TokSymbol SymSemi $1 }+    | ':'                       { TokSymbol SymColon $1 }+    | '='                       { TokSymbol SymEqual $1 }+    | '_'                       { TokSymbol SymUnderscore $1 }+    | '?'                       { TokSymbol SymQuestionMark $1 }+    | '->'                      { TokSymbol SymArrow $1 }+    | '\\'                      { TokSymbol SymLambda $1 }+    | '@'                       { TokSymbol SymAs $1 }+    | '|'                       { TokSymbol SymBar $1 }+    | '('                       { TokSymbol SymOpenParen $1 }+    | ')'                       { TokSymbol SymCloseParen $1 }+    | '(|'                      { TokSymbol SymOpenIdiomBracket $1 }+    | '|)'                      { TokSymbol SymCloseIdiomBracket $1 }+    | '(|)'                     { TokSymbol SymEmptyIdiomBracket $1 }+    | '{{'                      { TokSymbol SymDoubleOpenBrace $1 }+    | '}}'                      { TokSymbol SymDoubleCloseBrace $1 }+    | '{'                       { TokSymbol SymOpenBrace $1 }+    | '}'                       { TokSymbol SymCloseBrace $1 }+    | vopen                     { TokSymbol SymOpenVirtualBrace $1 }+    | vclose                    { TokSymbol SymCloseVirtualBrace $1 }+    | vsemi                     { TokSymbol SymVirtualSemi $1 }+    | '{-#'                     { TokSymbol SymOpenPragma $1 }+    | '#-}'                     { TokSymbol SymClosePragma $1 }++    | id                        { TokId $1 }+    | q_id                      { TokQId $1 }+    | string                    { TokString $1 }++    | literal                   { TokLiteral $1 }++{--------------------------------------------------------------------------+    Top level+ --------------------------------------------------------------------------}++File :: { Module }+File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }++maybe_vclose :: { () }+maybe_vclose : {- empty -} { () }+             | vclose      { () }++{--------------------------------------------------------------------------+    Meta rules+ --------------------------------------------------------------------------}++{-  A layout block might have to be closed by a parse error. Example:+        let x = e in e'+    Here the 'let' starts a layout block which should end before the 'in'.  The+    problem is that the lexer doesn't know this, so there is no virtual close+    brace. However when the parser sees the 'in' there will be a parse error.+    This is our cue to close the layout block.+-}+close :: { () }+close : vclose  { () }+      | error   {% popBlock }+++-- You can use concrete semi colons in a layout block started with a virtual+-- brace, so we don't have to distinguish between the two semi colons. You can't+-- use a virtual semi colon in a block started by a concrete brace, but this is+-- simply because the lexer will not generate virtual semis in this case.+semi :: { Interval }+semi : ';'    { $1 }+     | vsemi  { $1 }+++-- Enter the 'imp_dir' lex state, where we can parse the keyword 'to'.+beginImpDir :: { () }+beginImpDir : {- empty -}   {% pushLexState imp_dir }++{--------------------------------------------------------------------------+    Helper rules+ --------------------------------------------------------------------------}++-- A float. Used in fixity declarations.+Float :: { Ranged Double }+Float : literal {% forM $1 $ \case+                   { LitNat   i -> return $ fromInteger i+                   ; LitFloat d -> return d+                   ; _          -> parseError $ "Expected floating point number"+                   }+                }+++{--------------------------------------------------------------------------+    Names+ --------------------------------------------------------------------------}++-- A name is really a sequence of parts, but the lexer just sees it as a+-- string, so we have to do the translation here.+Id :: { Name }+Id : id     {% mkName $1 }++-- Space separated list of one or more identifiers.+SpaceIds :: { List1 Name }+SpaceIds+    : 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+  : '..' Id { setRelevance NonStrict $ defaultArg $2 }+  | '.'  Id { setRelevance Irrelevant $ defaultArg $2 }+  | Id      { defaultArg $1 }++-- Space separated list of one or more possibly dotted identifiers.+MaybeDottedIds :: { List1 (Arg Name) }+MaybeDottedIds+    : MaybeDottedId MaybeDottedIds { $1 <| $2 }+    | MaybeDottedId                { singleton $1 }++-- Space separated list of one or more identifiers, some of which may+-- 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 . setRelevance Irrelevant . defaultArg) $3 <> $5 }+    | '.' '{' SpaceIds '}'            { fmap (hide . setRelevance Irrelevant . defaultArg) $3 }+    | '.' '{{' SpaceIds DoubleCloseBrace ArgIds   { fmap (makeInstance . setRelevance Irrelevant . defaultArg) $3 <> $5 }+    | '.' '{{' SpaceIds DoubleCloseBrace          { fmap (makeInstance . setRelevance Irrelevant . defaultArg) $3 }+    | '..' '{' SpaceIds '}' ArgIds    { fmap (hide . setRelevance NonStrict . defaultArg) $3 <> $5 }+    | '..' '{' SpaceIds '}'           { fmap (hide . setRelevance NonStrict . defaultArg) $3 }+    | '..' '{{' SpaceIds DoubleCloseBrace ArgIds  { fmap (makeInstance . setRelevance NonStrict . defaultArg) $3 <> $5 }+    | '..' '{{' SpaceIds DoubleCloseBrace         { fmap (makeInstance . setRelevance NonStrict . defaultArg) $3 }++-- Modalities preceeding identifiers++ModalArgIds :: { ([Attr], List1 (Arg Name)) }+ModalArgIds : Attributes ArgIds  {% ($1,) `fmap` mapM (applyAttrs $1) $2 }++-- Attributes are parsed as '@' followed by an atomic expression.++Attribute :: { Attr }+Attribute : '@' ExprOrAttr  {% setRange (getRange ($1,$2)) `fmap` toAttribute $2 }++-- Parse a reverse list of modalities++Attributes :: { [Attr] }+Attributes : {- empty -}  { [] }+  | Attributes Attribute { $2 : $1 }++Attributes1 :: { List1 Attr }+Attributes1 : Attribute  { singleton $1 }+  | Attributes1 Attribute { $2 <| $1 }++QId :: { QName }+QId : q_id  {% mkQName $1 }+    | Id    { QName $1 }+++-- A module name is just a qualified name+ModuleName :: { QName }+ModuleName : QId { $1 }+++-- A binding variable. Can be '_'+BId :: { Name }+BId : Id    { $1 }+    | '_'   { setRange (getRange $1) simpleHole }++{- UNUSED+-- A binding variable. Can be '_'+MaybeDottedBId :: { (Relevance, Name) }+MaybeDottedBId+    : BId        { (Relevant  , $1) }+    | '.' BId    { (Irrelevant, $2) }+    | '..' BId   { (NonStrict, $2) }+-}+++-- Space separated list of binding identifiers. Used in fixity+-- declarations infixl 100 + -+SpaceBIds :: { List1 Name }+SpaceBIds+    : BId SpaceBIds { $1 <| $2 }+    | BId           { singleton $1 }++{- DOES PRODUCE REDUCE/REDUCE CONFLICTS!+-- Space-separated list of binding identifiers. Used in dependent+-- function spaces: (x y z : Nat) -> ...+-- (Used to be comma-separated; hence the name)+-- QUESTION: Should this be replaced by SpaceBIds above?+--CommaBIds :: { [(Relevance,Name)] }+CommaBIds :: { [Name] }+CommaBIds+    : CommaBIds BId { $1 ++ [$2] }  -- SWITCHING DOES NOT HELP+    | BId           { [$1] }+-}++-- Space-separated list of binding identifiers. Used in dependent+-- function spaces: (x y z : Nat) -> ...+-- (Used to be comma-separated; hence the name)+-- QUESTION: Should this be replaced by SpaceBIds above?+-- Andreas, 2011-04-07 the trick avoids reduce/reduce conflicts+-- when parsing  (x y z : A) -> B+-- at point (x y  it is not clear whether x y is an application or+-- a variable list. We could be parsing (x y z) -> B+-- with ((x y) z) being a type.+CommaBIds :: { List1 (NamedArg Binder) }+CommaBIds : CommaBIdAndAbsurds {%+    case $1 of+      Left ns -> return ns+      Right _ -> parseError $ "expected sequence of bound identifiers, not absurd pattern"+    }++CommaBIdAndAbsurds :: { Either (List1 (NamedArg Binder)) (List1 Expr) }+CommaBIdAndAbsurds+  : Application {% boundNamesOrAbsurd $1 }+  | QId '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Left $3) }+  | '_' '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Left $3) }+  | QId '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Right $ getRange $3) }+  | '_' '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Right $ getRange $3) }++-- Parse a sequence of identifiers, including hiding info.+-- Does not include instance arguments.+-- E.g. x {y z} _ {v}+-- To be used in typed bindings, like (x {y z} _ {v} : Nat).+BIdsWithHiding :: { List1 (NamedArg Binder) }+BIdsWithHiding : Application {%+  -- interpret an expression as a name and maybe a pattern+  case mapM exprAsNameOrHiddenNames $1 of+    Nothing   -> parseError "Expected sequence of possibly hidden bound identifiers"+    Just good -> forM (sconcat good) $ updateNamedArgA $ \ (n, me) -> do+                   p <- traverse exprToPattern me+                   pure $ Binder p (mkBoundName_ n)+    }+++-- Space separated list of strings in a pragma.+PragmaStrings :: { [String] }+PragmaStrings+    : {- empty -}           { [] }+    | string PragmaStrings  { snd $1 : $2 }+{- Unused+PragmaString :: { String }+PragmaString+    : string { snd $1 }+-}+Strings :: { [(Interval, String)] }+Strings : {- empty -}    { [] }+        | string Strings { $1 : $2 }++ForeignCode :: { [(Interval, String)] }+ForeignCode+  : {- empty -} { [] }+  | string ForeignCode { $1 : $2 }+  | '{-#' ForeignCode '#-}' ForeignCode { [($1, "{-#")] ++ $2 ++ [($3, "#-}")] ++ $4 }++PragmaName :: { Name }+PragmaName : string {% mkName $1 }++PragmaQName :: { QName }+PragmaQName : string {% pragmaQName $1 }  -- Issue 2125. WAS: string {% fmap QName (mkName $1) }++PragmaQNames :: { [QName] }+PragmaQNames : Strings {% mapM pragmaQName $1 }++{--------------------------------------------------------------------------+    Expressions (terms and types)+ --------------------------------------------------------------------------}++{-  Expressions. You might expect lambdas and lets to appear in the first+    expression category (lowest precedence). The reason they don't is that we+    want to parse things like++        m >>= \x -> k x++    This will leads to a conflict in the following case++        m >>= \x -> k x >>= \y -> k' y++    At the second '>>=' we can either shift or reduce. We solve this problem+    using Happy's precedence directives. The rule 'Expr -> Expr1' (which is the+    rule you shouldn't use to reduce when seeing '>>=') is given LOWEST+    precedence.  The terminals '->' and op (which is what you should shift)+    is given higher precedence.+-}++-- Top level: Function types.+Expr :: { Expr }+Expr+  : TeleArrow Expr                      { Pi $1 $2 }+  | Application3 '->' Expr              { Fun (getRange ($1,$2,$3))+                                              (defaultArg $ rawApp $1)+                                              $3 }+  | Attributes1 Application3 '->' Expr  {% applyAttrs1 $1 (defaultArg $ rawApp $2) <&> \ dom ->+                                             Fun (getRange ($1,$2,$3,$4)) dom $4 }+  | Expr1 %prec LOWEST                  { $1 }++-- Level 1: Application+Expr1 :: { Expr }+Expr1+  : UnnamedWithExprs+      {% case $1 of+           { e :| [] -> return e+           ; e :| es -> return $ WithApp (fuseRange e es) e es+           }+      }++WithExprs :: { List1 (Named Name Expr) }+WithExprs+  : Application3 'in' Id     '|' WithExprs { named $3  (rawApp $1) <| $5 }+  | Application3 {- empty -} '|' WithExprs { unnamed   (rawApp $1) <| $3 }+  | Application3 'in' Id                   { singleton (named $3 (rawApp $1)) }+  | Application3 {- empty -}               { singleton (unnamed  (rawApp $1)) }++UnnamedWithExprs :: { List1 Expr }+UnnamedWithExprs+  :  Application3 '|' UnnamedWithExprs { (rawApp $1) <| $3 }+  | {- empty -} Application            { singleton (rawApp $1) }++Application :: { List1 Expr }+Application+    : Expr2             { singleton $1 }+    | Expr3 Application { $1 <| $2 }++-- Level 2: Lambdas and lets+Expr2 :: { Expr }+Expr2+    : '\\' LamBindings Expr        { Lam (getRange ($1,$2,$3)) $2 $3 }+    | 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) }++LetBody :: { Maybe Expr }+LetBody : 'in' Expr   { Just $2 }+        | {- empty -} { Nothing }++ExtendedOrAbsurdLam :: { Expr }+ExtendedOrAbsurdLam+    : '\\'             '{' LamClauses '}'                  {% extLam (getRange ($1, $2, $4))     []                $3 }+    | '\\' Attributes1 '{' LamClauses '}'                  {% extLam (getRange ($1, $3, $5))     (List1.toList $2) $4 }+    | '\\'             'where' vopen LamWhereClauses close {% extLam (getRange ($1, $2, $3, $5)) []                $4 }+    | '\\' Attributes1 'where' vopen LamWhereClauses close {% extLam (getRange ($1, $3, $4, $6)) (List1.toList $2) $5 }+    | '\\'             AbsurdLamBindings                   {% extOrAbsLam (getRange $1) []                $2 }+    | '\\' Attributes1 AbsurdLamBindings                   {% extOrAbsLam (getRange $1) (List1.toList $2) $3 }++Application3 :: { List1 Expr }+Application3+    : Expr3              { singleton $1 }+    | Expr3 Application3 { $1 <| $2 }++-- Christian Sattler, 2017-08-04, issue #2671+-- We allow empty lists of expressions for the LHS of extended lambda clauses.+-- I am not sure what Application3 is otherwise used for, so I keep the+-- original type and create this copy solely for extended lambda clauses.+Application3PossiblyEmpty :: { [Expr] }+Application3PossiblyEmpty+    :                                 { [] }+    | Expr3 Application3PossiblyEmpty { $1 : $2 }++-- 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 }++Expr3NoCurly :: { Expr }+Expr3NoCurly+    : '?'                               { QuestionMark (getRange $1) Nothing }+    | '_'                               { Underscore (getRange $1) Nothing }+    | 'quote'                           { Quote (getRange $1) }+    | 'quoteTerm'                       { QuoteTerm (getRange $1) }+    | 'unquote'                         { Unquote (getRange $1) }+    | '(|' UnnamedWithExprs '|)'        { IdiomBrackets (getRange ($1,$2,$3)) (List1.toList $2) }+    | '(|)'                             { IdiomBrackets (getRange $1) [] }+    | '(' ')'                           { Absurd (fuseRange $1 $2) }+    | Id '@' Expr3                      { As (getRange ($1,$2,$3)) $1 $3 }+    | '.' Expr3                         { Dot (fuseRange $1 $2) $2 }+    | '..' Expr3                        { DoubleDot (fuseRange $1 $2) $2 }+    | 'record' '{' RecordAssignments '}' { Rec (getRange ($1,$2,$3,$4)) $3 }+    | 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (getRange ($1,$2,$3,$4,$5)) $2 $4 }+    | '...'                             { Ellipsis (getRange $1) }+    | ExprOrAttr                       { $1 }++-- Level 4: Maybe named, or cubical faces+Expr4 :: { Expr }+Expr4 : Expr1 '=' Expr { Equal (getRange ($1, $2, $3)) $1 $3 }+      | Expr           { $1 }++ExprOrAttr :: { Expr }+ExprOrAttr+    : QId           { Ident $1 }+    | literal       { Lit (getRange $1) (rangedThing $1) }+    | '(' Expr4 ')' { Paren (getRange ($1,$2,$3)) $2 }+    -- ^ this is needed for cubical stuff++Expr3 :: { Expr }+Expr3+    : Expr3Curly   { $1 }+    | Expr3NoCurly { $1 }++RecordAssignments :: { RecordAssignments }+RecordAssignments+  : {- empty -}        { [] }+  | RecordAssignments1 { List1.toList $1 }++RecordAssignments1 :: { List1 RecordAssignment }+RecordAssignments1+  : RecordAssignment                        { singleton $1 }+  | RecordAssignment ';' RecordAssignments1 { $1 <| $3 }++RecordAssignment :: { RecordAssignment }+RecordAssignment+  : FieldAssignment  { Left  $1 }+  | ModuleAssignment { Right $1 }++ModuleAssignment :: { ModuleAssignment }+ModuleAssignment+  : ModuleName OpenArgs ImportDirective  { ModuleAssignment $1 $2 $3 }++FieldAssignments :: { [FieldAssignment] }+FieldAssignments+  : {- empty -}       { [] }+  | FieldAssignments1 { List1.toList $1 }++FieldAssignments1 :: { List1 FieldAssignment }+FieldAssignments1+  : FieldAssignment                       { singleton $1 }+  | FieldAssignment ';' FieldAssignments1 { $1 <| $3 }++FieldAssignment :: { FieldAssignment }+FieldAssignment+  : Id '=' Expr   { FieldAssignment $1 $3 }++{--------------------------------------------------------------------------+    Bindings+ --------------------------------------------------------------------------}++-- "Delta ->" to avoid conflict between Delta -> Gamma and Delta -> A.+TeleArrow :: { Telescope1 }+TeleArrow : Telescope1 '->' { $1 }++Telescope1 :: { Telescope1 }+Telescope1 : TypedBindings { $1 }++TypedBindings :: { List1 TypedBinding }+TypedBindings+    : TypedBinding TypedBindings { $1 <| $2 }+    | TypedBinding               { singleton $1 }+++-- A typed binding is either (x1 .. xn : A) or   {y1 .. ym : B}+-- Andreas, 2011-04-07: or  .(x1 .. xn : A) or  .{y1 .. ym : B}+-- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B}+TypedBinding :: { TypedBinding }+TypedBinding+    : '.' '(' TBindWithHiding ')'    { setRange (getRange ($2,$3,$4)) $+                             setRelevance Irrelevant $3 }+    | '.' '{' TBind '}'    { setRange (getRange ($2,$3,$4)) $+                             setHiding Hidden $+                             setRelevance Irrelevant $3 }+    | '.' '{{' TBind DoubleCloseBrace+                           { setRange (getRange ($2,$3,$4)) $+                             makeInstance $+                             setRelevance Irrelevant $3 }+    | '..' '(' TBindWithHiding ')'   { setRange (getRange ($2,$3,$4)) $+                             setRelevance NonStrict $3 }+    | '..' '{' TBind '}'   { setRange (getRange ($2,$3,$4)) $+                             setHiding Hidden $+                             setRelevance NonStrict $3 }+    | '..' '{{' TBind DoubleCloseBrace+                           { setRange (getRange ($2,$3,$4)) $+                             makeInstance $+                             setRelevance NonStrict $3 }+    | '(' TBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }+    | '(' ModalTBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }+    | '{{' TBind DoubleCloseBrace+                           { setRange (getRange ($1,$2,$3)) $+                             makeInstance $2 }+    | '{{' ModalTBind DoubleCloseBrace+                           { setRange (getRange ($1,$2,$3)) $+                             makeInstance $2 }+    | '{' TBind '}'        { setRange (getRange ($1,$2,$3)) $+                             setHiding Hidden $2 }+    | '{' ModalTBind '}'   { setRange (getRange ($1,$2,$3)) $+                             setHiding Hidden $2 }+    | '(' Open ')'               { TLet (getRange ($1,$3)) $2 }+    | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 }+++-- x1 .. xn : A+-- x1 .. xn :{i1 i2 ..} A+TBind :: { TypedBinding }+TBind : CommaBIds ':' Expr  {+    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings+    in TBind r $1 $3+  }++ModalTBind :: { TypedBinding }+ModalTBind : Attributes1 CommaBIds ':' Expr  {% do+    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings+    xs <- mapM (applyAttrs1 $1 . setTacticAttr $1) $2+    return $ TBind r xs $4+  }++-- x {y z} _ {v} : A+TBindWithHiding :: { TypedBinding }+TBindWithHiding : BIdsWithHiding ':' Expr  {+    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings+    in TBind r $1 $3+  }++ModalTBindWithHiding :: { TypedBinding }+ModalTBindWithHiding : Attributes1 BIdsWithHiding ':' Expr  {% do+    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings+    xs <- mapM (applyAttrs1 $1 . setTacticAttr $1) $2+    return $ TBind r xs $4+  }++-- A non-empty sequence of lambda bindings.+LamBindings :: { List1 LamBinding }+LamBindings+  : LamBinds '->' {%+      case absurdBinding $1 of+        Just{}  -> parseError "Absurd lambda cannot have a body."+        Nothing -> return $ List1.fromList $ lamBindings $1+      }++AbsurdLamBindings :: { Either ([LamBinding], Hiding) (List1 Expr) }+AbsurdLamBindings+  : LamBindsAbsurd {%+    case $1 of+      Left lb -> case absurdBinding lb of+                   Nothing -> parseError "Missing body for lambda"+                   Just h  -> return $ Left (lamBindings lb, h)+      Right es -> return $ Right es+    }++-- 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) }++-- 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) }++-- 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.+NonAbsurdLamClause :: { LamClause }+NonAbsurdLamClause+  : Application3PossiblyEmpty '->' Expr {% mkLamClause False $1 (RHS $3) }+  | CatchallPragma+    Application3PossiblyEmpty '->' Expr {% mkLamClause True  $2 (RHS $4) }++AbsurdLamClause :: { LamClause }+AbsurdLamClause+-- FNF, 2011-05-09: By being more liberal here, we avoid shift/reduce and reduce/reduce errors.+-- Later stages such as scope checking will complain if we let something through which we should not+  : Application                {% mkAbsurdLamClause False $1 }+  | CatchallPragma Application {% mkAbsurdLamClause True  $2 }++LamClause :: { LamClause }+LamClause+  : NonAbsurdLamClause { $1 }+  | AbsurdLamClause { $1 }++-- Parses all extended lambda clauses except for a single absurd clause, which is taken care of+-- in AbsurdLambda+LamClauses :: { List1 LamClause }+LamClauses+   : LamClauses semi LamClause { $3 <| $1 }+   | AbsurdLamClause semi LamClause { $3 <| singleton $1 }+   | NonAbsurdLamClause { singleton $1 }++-- Parses all extended lambda clauses including a single absurd clause. For λ+-- where this is not taken care of in AbsurdLambda+LamWhereClauses :: { List1 LamClause }+LamWhereClauses+   : LamWhereClauses semi LamClause { $3 <| $1 }+   | LamClause { singleton $1 }++ForallBindings :: { List1 LamBinding }+ForallBindings+  : TypedUntypedBindings1 '->' { $1 }++-- A non-empty sequence of possibly untyped bindings.+TypedUntypedBindings1 :: { List1 LamBinding }+TypedUntypedBindings1+  : DomainFreeBinding TypedUntypedBindings1 { fmap DomainFree $1 <> $2 }+  | TypedBinding TypedUntypedBindings1      { DomainFull $1 <| $2 }+  | DomainFreeBinding                       { fmap DomainFree $1 }+  | TypedBinding                            { singleton $ DomainFull $1 }++-- A possibly empty sequence of possibly untyped bindings.+-- This is used as telescope in data and record decls.+TypedUntypedBindings :: { [LamBinding] }+TypedUntypedBindings+  : DomainFreeBinding TypedUntypedBindings { map DomainFree (List1.toList $1) ++ $2 }+  | TypedBinding TypedUntypedBindings      { DomainFull $1 : $2 }+  |                                        { [] }++DomainFreeBindings :: { [NamedArg Binder] }+DomainFreeBindings+  : {- empty -}                          { [] }+  | DomainFreeBinding DomainFreeBindings { List1.toList $1 ++ $2 }++-- A domain free binding is either x or {x1 .. xn}+DomainFreeBinding :: { List1 (NamedArg Binder) }+DomainFreeBinding+  : DomainFreeBindingAbsurd {% case $1 of+                             Left lbs -> return lbs+                             Right _ -> parseError "expected sequence of bound identifiers, not absurd pattern"+                          }++MaybeAsPattern :: { Maybe Pattern }+MaybeAsPattern+  : '@' Expr3   {% fmap Just (exprToPattern $2) }+  | {- empty -} { Nothing }++-- A domain free binding is either x or {x1 .. xn}+DomainFreeBindingAbsurd :: { Either (List1 (NamedArg Binder)) (List1 Expr)}+DomainFreeBindingAbsurd+    : BId      MaybeAsPattern { Left . singleton $ mkDomainFree_ id $2 $1 }+    | '.' BId  MaybeAsPattern { Left . singleton $ mkDomainFree_ (setRelevance Irrelevant) $3 $2 }+    | '..' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (setRelevance NonStrict) $3 $2 }+    | '(' Application ')'     {% exprToPattern (rawApp $2) >>= \ p ->+                                 pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole }+    | '(' Attributes1 CommaBIdAndAbsurds ')'+         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->+              first (fmap (setTacticAttr $2 . setArgInfo ai)) $3 }+    | '{' CommaBIdAndAbsurds '}'+         { first (fmap hide) $2 }+    | '{' Attributes1 CommaBIdAndAbsurds '}'+         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->+              first (fmap (hide . setTacticAttr $2 . setArgInfo ai)) $3 }+    | '{{' CommaBIds DoubleCloseBrace { Left $ fmap makeInstance $2 }+    | '{{' Attributes1 CommaBIds DoubleCloseBrace+         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->+              Left $ fmap (makeInstance . setTacticAttr $2 . setArgInfo ai) $3 }+    | '.' '{' CommaBIds '}' { Left $ fmap (hide . setRelevance Irrelevant) $3 }+    | '.' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . setRelevance Irrelevant) $3 }+    | '..' '{' CommaBIds '}' { Left $ fmap (hide . setRelevance NonStrict) $3 }+    | '..' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . setRelevance NonStrict) $3 }+++{--------------------------------------------------------------------------+    Do-notation+ --------------------------------------------------------------------------}++DoStmts :: { List1 DoStmt }+DoStmts : DoStmt              { singleton $1 }+        | DoStmt vsemi        { singleton $1 }    -- #3046+        | DoStmt semi DoStmts { $1 <| $3 }++DoStmt :: { DoStmt }+DoStmt : Expr DoWhere {% buildDoStmt $1 $2 }++DoWhere :: { [LamClause] }+DoWhere+  : {- empty -} { [] }+  | 'where' vopen LamWhereClauses close { reverse (List1.toList $3) }++{--------------------------------------------------------------------------+    Modules and imports+ --------------------------------------------------------------------------}++-- Import directives+ImportDirective :: { ImportDirective }+ImportDirective+  : ImportDirective1 ImportDirective { $1 <> $2 }+  | {- empty -}                      { mempty }++ImportDirective1 :: { ImportDirective }+  : 'public'      { defaultImportDir { importDirRange = getRange $1, publicOpen = Just (getRange $1) } }+  | Using         { defaultImportDir { importDirRange = snd $1, using    = fst $1 } }+  | Hiding        { defaultImportDir { importDirRange = snd $1, hiding   = fst $1 } }+  | RenamingDir   { defaultImportDir { importDirRange = snd $1, impRenaming = fst $1 } }++Using :: { (Using, Range) }+Using+    : 'using' '(' CommaImportNames ')'   { (Using $3 , getRange ($1,$2,$3,$4)) }+        -- using can have an empty list++Hiding :: { ([ImportedName], Range) }+Hiding+    : 'hiding' '(' CommaImportNames ')'  { ($3 , getRange ($1,$2,$3,$4)) }+        -- if you want to hide nothing that's fine, isn't it?++RenamingDir :: { ([Renaming] , Range) }+RenamingDir+    : 'renaming' '(' Renamings ')'      { ($3 , getRange ($1,$2,$3,$4)) }+    | 'renaming' '(' ')'                { ([] , getRange ($1,$2,$3)) }++-- Renamings of the form 'x to y'+Renamings :: { [Renaming] }+Renamings+    : Renaming ';' Renamings    { $1 : $3 }+    | Renaming                  { [$1] }++Renaming :: { Renaming }+Renaming+    : ImportName_ 'to' RenamingTarget { Renaming $1 (setImportedName $1 (snd $3)) (fst $3) (getRange $2) }++RenamingTarget :: { (Maybe Fixity, Name) }+RenamingTarget+    : Id                 { (Nothing, $1) }+    | 'infix'  Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) NonAssoc)  , $3) }+    | 'infixl' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) LeftAssoc) , $3) }+    | 'infixr' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) RightAssoc), $3) }++-- We need a special imported name here, since we have to trigger+-- the imp_dir state exactly one token before the 'to'+ImportName_ :: { ImportedName }+ImportName_+    : beginImpDir Id          { ImportedName $2 }+    | 'module' beginImpDir Id { ImportedModule $3 }++ImportName :: { ImportedName }+ImportName : Id          { ImportedName $1 }+           | 'module' Id { ImportedModule $2 }++-- Actually semi-colon separated, possibly empty list of ImportName.+CommaImportNames :: { [ImportedName] }+CommaImportNames+    : {- empty -}       { [] }+    | CommaImportNames1 { List1.toList $1 }++CommaImportNames1 :: { List1 ImportedName }+CommaImportNames1+    : ImportName                        { singleton $1 }+    | ImportName ';' CommaImportNames1  { $1 <| $3 }++{--------------------------------------------------------------------------+    Function clauses+ --------------------------------------------------------------------------}++-- A left hand side of a function clause. We parse it as an expression, and+-- then check that it is a valid left hand side.+LHS :: { [RewriteEqn] -> [WithExpr] -> LHS }+LHS : Expr1 {% exprToLHS $1 }++WithClause :: { [Either RewriteEqn (List1 (Named Name Expr))] }+WithClause+  : 'with' WithExprs WithClause+    {% fmap (++ $3) (buildWithStmt $2)  }+  | 'rewrite' UnnamedWithExprs WithClause+    { Left (Rewrite $ fmap ((),) $2) : $3 }+  | {- empty -} { [] }++-- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@.+HoleContent :: { HoleContent }+HoleContent+  : Expr                   {  HoleContentExpr    $1 }+  | WithClause+    {% fmap HoleContentRewrite $ forM $1 $ \case+         Left r  -> pure r+         Right{} -> parseError "Cannot declare a 'with' abstraction from inside a hole."+      }++-- Where clauses are optional.+WhereClause :: { WhereClause }+WhereClause+    : {- empty -}                               { NoWhere }+    |                     'where' Declarations0 { AnyWhere  (getRange $1) $2 }+    | 'module' Id         'where' Declarations0 { SomeWhere (getRange ($1,$3)) $2 PublicAccess $4 }+    | 'module' Underscore 'where' Declarations0 { SomeWhere (getRange ($1,$3)) $2 PublicAccess $4 }+  -- Note: The access modifier is a dummy, it is computed in the nicifier.++ExprWhere :: { ExprWhere }+ExprWhere : Expr WhereClause { ExprWhere $1 $2 }++{--------------------------------------------------------------------------+    Different kinds of declarations+ --------------------------------------------------------------------------}++-- Top-level definitions.+Declaration :: { List1 Declaration }+Declaration+    : Fields          { singleton $1 }+    | FunClause       { $1 }            -- includes type signatures+    | Data            { singleton $1 }+    | DataSig         { singleton $1 }  -- lone data type signature in mutual block+    | Record          { singleton $1 }+    | RecordSig       { singleton $1 }  -- lone record signature in mutual block+    | Infix           { singleton $1 }+    | Generalize      { singleton $1 }+    | Mutual          { singleton $1 }+    | Abstract        { singleton $1 }+    | Private         { singleton $1 }+    | Instance        { singleton $1 }+    | Macro           { singleton $1 }+    | Postulate       { singleton $1 }+    | Primitive       { singleton $1 }+    | Open            { $1 }+    | ModuleMacro     { singleton $1 }+    | Module          { singleton $1 }+    | Pragma          { singleton $1 }+    | Syntax          { singleton $1 }+    | PatternSyn      { singleton $1 }+    | UnquoteDecl     { singleton $1 }+    | Constructor     { singleton $1 }++{--------------------------------------------------------------------------+    Individual declarations+ --------------------------------------------------------------------------}++-- Type signatures of the form "n1 n2 n3 ... : Type", with at least+-- one bound name.+TypeSigs :: { List1 Declaration }+TypeSigs : SpaceIds ':' Expr { fmap (\ x -> typeSig defaultArgInfo Nothing x $3) $1 }++-- A variant of TypeSigs where any sub-sequence of names can be marked+-- as hidden or irrelevant using braces and dots:+-- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type.+ArgTypeSigs :: { List1 (Arg Declaration) }+ArgTypeSigs+  : ModalArgIds ':' Expr { let (attrs, xs) = $1 in+                           fmap (fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $3)) xs }+  | 'overlap' ModalArgIds ':' Expr {%+      let (attrs, 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 }+  | 'instance' ArgTypeSignatures {+    let+      setInstance (TypeSig info tac x t) = TypeSig (makeInstance info) tac x t+      setInstance _ = __IMPOSSIBLE__ in+    fmap (fmap setInstance) $2 }++-- 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.+FunClause :: { List1 Declaration }+FunClause+  : {- emptyb -} LHS WHS RHS WhereClause {% funClauseOrTypeSigs [] $1 $2 $3 $4 }+  | Attributes1  LHS WHS RHS WhereClause {% funClauseOrTypeSigs (List1.toList $1) $2 $3 $4 $5 }++-- "With Hand Side", in between the Left & the Right hand ones+WHS :: { [Either RewriteEqn (List1 (Named Name Expr))] }+WHS+  : {- empty -}                           { [] }+  | 'with'    WithExprs        WithClause {% fmap (++ $3) (buildWithStmt $2) }+  | 'rewrite' UnnamedWithExprs WithClause { Left (Rewrite $ fmap ((),) $2) : $3 }++RHS :: { RHSOrTypeSigs }+RHS+  : {- empty -}    { JustRHS AbsurdRHS }+  | '='       Expr { JustRHS (RHS $2) }+  | ':'       Expr { TypeSigsRHS $2 }++-- Data declaration. Can be local.+Data :: { Declaration }+Data : 'data' Id TypedUntypedBindings ':' Expr 'where'+            Declarations0       { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) $2 $3 $5 $7 }++  -- New cases when we already had a DataSig.  Then one can omit the sort.+     | 'data' Id TypedUntypedBindings 'where'+            Declarations0       { DataDef (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }++-- Data type signature. Found in mutual blocks.+DataSig :: { Declaration }+DataSig : 'data' Id TypedUntypedBindings ':' Expr+  { DataSig (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }++-- Andreas, 2012-03-16:  The Expr3NoCurly instead of Id in everything+-- following 'record' is to remove the (harmless) shift/reduce conflict+-- introduced by record update expressions.++-- Record declarations.+Record :: { Declaration }+Record : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr 'where'+            RecordDeclarations+         {% exprToName $2 >>= \ n -> let (dir, ds) = $7 in return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7)) n dir $3 $5 ds }+       | 'record' Expr3NoCurly TypedUntypedBindings 'where'+            RecordDeclarations+         {% exprToName $2 >>= \ n -> let (dir, ds) = $5 in return $ RecordDef (getRange ($1,$2,$3,$4,$5)) n dir $3 ds }++-- Record type signature. In mutual blocks.+RecordSig :: { Declaration }+RecordSig : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr+  {% exprToName $2 >>= \ n -> return $ RecordSig (getRange ($1,$2,$3,$4,$5)) n $3 $5 }++Constructor :: { Declaration }+Constructor : 'data' '_' 'where' Declarations0+  { LoneConstructor (getRange ($1,$4)) $4 }++-- Declaration of record constructor name.+RecordConstructorName :: { (Name, IsInstance) }+RecordConstructorName :                  'constructor' Id       { ($2, NotInstanceDef) }+                      | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (getRange $1)) }+++-- Fixity declarations.+Infix :: { Declaration }+Infix : 'infix'  Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) NonAssoc)   $3 }+      | 'infixl' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) LeftAssoc)  $3 }+      | 'infixr' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) RightAssoc) $3 }++-- Field declarations.+Fields :: { Declaration }+Fields : 'field' ArgTypeSignaturesOrEmpty+            { let+                inst i = case getHiding i of+                           Instance _ -> InstanceDef noRange  -- no @instance@ keyword here+                           _          -> NotInstanceDef+                toField (Arg info (TypeSig info' tac x t)) = FieldSig (inst info') tac x (Arg info t)+              in Field (fuseRange $1 $2) $ map toField $2 }+  -- | 'field' ModalArgTypeSignatures+  --           { let+  --               inst i = case getHiding i of+  --                          Instance _ -> InstanceDef+  --                          _          -> NotInstanceDef+  --               toField (Arg info (TypeSig info' x t)) = FieldSig (inst info') x (Arg info t)+  --             in Field (fuseRange $1 $2) $ map toField $2 }++-- 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 (fuseRange $1 $2) (map toGeneralize $2) }++-- Mutually recursive declarations.+Mutual :: { Declaration }+Mutual : 'mutual' Declarations0  { Mutual (fuseRange $1 $2) $2 }+       | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (getRange ($1,$2,$3)) $3 }++-- Abstract declarations.+Abstract :: { Declaration }+Abstract : 'abstract' Declarations0  { Abstract (fuseRange $1 $2) $2 }+++-- Private can only appear on the top-level (or rather the module level).+Private :: { Declaration }+Private : 'private' Declarations0        { Private (fuseRange $1 $2) UserWritten $2 }+++-- Instance declarations.+Instance :: { Declaration }+Instance : 'instance' Declarations0  { InstanceB (getRange $1) $2 }+++-- Macro declarations.+Macro :: { Declaration }+Macro : 'macro' Declarations0 { Macro (fuseRange $1 $2) $2 }+++-- Postulates.+Postulate :: { Declaration }+Postulate : 'postulate' Declarations0 { Postulate (fuseRange $1 $2) $2 }++-- Primitives. Can only contain type signatures.+Primitive :: { Declaration }+Primitive : 'primitive' ArgTypeSignaturesOrEmpty  {+  let { setArg (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t+      ; setArg _ = __IMPOSSIBLE__ } in+  Primitive (fuseRange $1 $2) (map setArg $2) }++-- Unquoting declarations.+UnquoteDecl :: { Declaration }+UnquoteDecl+  : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }+  | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) (List1.toList $2) $4 }+  | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) (List1.toList $2) $4 }++-- Syntax declaration (To declare eg. mixfix binders)+Syntax :: { Declaration }+Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%+  case $2 of+    Name _ _ (_ :| []) -> case mkNotation $3 $5 of+      Left err -> parseError $ "Malformed syntax declaration: " ++ err+      Right n -> return $ Syntax $2 n+    _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"+}++-- Pattern synonyms.+PatternSyn :: { Declaration }+PatternSyn : 'pattern' Id PatternSynArgs '=' Expr {% do+  p <- exprToPattern $5+  return (PatternSyn (getRange ($1,$2,$3,$4,$5)) $2 $3 p)+  }++PatternSynArgs :: { [Arg Name] }+PatternSynArgs : DomainFreeBindings    {% patternSynArgs $1 }++SimpleIds :: { [RString] }+SimpleIds : SimpleId { [$1] }+          | SimpleIds SimpleId {$1 ++ [$2]}++HoleNames :: { [NamedArg HoleName] }+HoleNames :                    { [] }+          | HoleNames HoleName {$1 ++ [$2]}++HoleName :: { NamedArg HoleName }+HoleName+  : 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 }++SimpleTopHole :: { HoleName }+SimpleTopHole+  : SimpleId { ExprHole $1 }+  | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole $3 $5 }+  | '(' '\\' '_'      '->' SimpleId ')' { LambdaHole (Ranged (getRange $3) "_") $5 }++SimpleHole :: { HoleName }+SimpleHole+  : SimpleId { ExprHole $1 }+  | '\\' SimpleId '->' SimpleId { LambdaHole $2 $4 }+  | '\\' '_'      '->' SimpleId { LambdaHole (Ranged (getRange $3) "_") $4 }+-- Variable name hole to be implemented later.++-- Discard the interval.+SimpleId :: { RString }+SimpleId : id  { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) }++MaybeOpen :: { Maybe Range }+MaybeOpen : 'open'      { Just (getRange $1) }+          | {- empty -} { Nothing }++-- 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 noRange m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir+    ; appStm m' es =+        Private r Inserted+          [ ModuleMacro r m'+             (SectionApp (getRange es) []+               (rawApp (Ident (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 {+    let+    { m   = $2+    ; es  = $3+    ; dir = $4+    ; r   = getRange ($1, m, es, dir)+    } in singleton $+      case es of+      { []  -> Open r m dir+      ; _   -> Private r Inserted+                 [ ModuleMacro r (noName $ beginningOf $ getRange m)+                             (SectionApp (getRange (m , es)) [] (rawApp (Ident m :| es)))+                             DoOpen dir+                 ]+      }+  }+  | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {+    let r = getRange $2 in singleton $+      Private r Inserted+      [ ModuleMacro r (noName $ beginningOf $ getRange $2) (RecordModuleInstance r $2) DoOpen $6+      ]+  }++OpenArgs :: { [Expr] }+OpenArgs : {- empty -}    { [] }+         | Expr3 OpenArgs { $1 : $2 }++ModuleApplication :: { Telescope -> Parser ModuleApplication }+ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\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" )+                    }+                  | ModuleName OpenArgs {+                    (\ts -> return $ SectionApp (getRange ($1, $2)) ts (rawApp (Ident $1 :| $2)) ) }+++-- Module instantiation+ModuleMacro :: { Declaration }+ModuleMacro : 'module' ModuleName TypedUntypedBindings '=' ModuleApplication ImportDirective+                    {% do { ma <- $5 (map addType $3)+                          ; name <- ensureUnqual $2+                          ; return $ ModuleMacro (getRange ($1, $2, ma, $6)) name ma DontOpen $6 } }+            | 'open' 'module' Id TypedUntypedBindings '=' ModuleApplication ImportDirective+                    {% do {ma <- $6 (map addType $4); return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) $3 ma DoOpen $7 } }++-- Module+Module :: { Declaration }+Module : 'module' ModuleName TypedUntypedBindings 'where' Declarations0+                    { Module (getRange ($1,$2,$3,$4,$5)) $2 (map addType $3) $5 }+       | 'module' Underscore TypedUntypedBindings 'where' Declarations0+                    { Module (getRange ($1,$2,$3,$4,$5)) (QName $2) (map addType $3) $5 }++Underscore :: { Name }+Underscore : '_' { noName (getRange $1) }++TopLevel :: { [Declaration] }+TopLevel : TopDeclarations { figureOutTopLevelModule $1 }++Pragma :: { Declaration }+Pragma : DeclarationPragma  { Pragma $1 }++DeclarationPragma :: { Pragma }+DeclarationPragma+  : BuiltinPragma            { $1 }+  | RewritePragma            { $1 }+  | CompilePragma            { $1 }+  | ForeignPragma            { $1 }+  | StaticPragma             { $1 }+  | InjectivePragma          { $1 }+  | InlinePragma             { $1 }+  | NoInlinePragma           { $1 }+  | ImpossiblePragma         { $1 }+  | TerminatingPragma        { $1 }+  | NonTerminatingPragma     { $1 }+  | NoTerminationCheckPragma { $1 }+  | NonCoveringPragma        { $1 }+  | WarningOnUsagePragma     { $1 }+  | WarningOnImportPragma    { $1 }+  | MeasurePragma            { $1 }+  | CatchallPragma           { $1 }+  | DisplayPragma            { $1 }+  | EtaPragma                { $1 }+  | NoPositivityCheckPragma  { $1 }+  | NoUniverseCheckPragma    { $1 }+  | PolarityPragma           { $1 }+  | OptionsPragma            { $1 }+    -- Andreas, 2014-03-06+    -- OPTIONS pragma not allowed everywhere, but don't give parse error.+    -- Give better error during type checking instead.++OptionsPragma :: { Pragma }+OptionsPragma : '{-#' 'OPTIONS' PragmaStrings '#-}' { OptionsPragma (getRange ($1,$2,$4)) $3 }++BuiltinPragma :: { Pragma }+BuiltinPragma+    : '{-#' 'BUILTIN' string PragmaQName '#-}'+      { BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (mkRString $3) $4 }+    -- Extra rule to accept keyword REWRITE also as built-in:+    | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'+      { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) (Ranged (getRange $3) "REWRITE") $4 }++RewritePragma :: { Pragma }+RewritePragma+    : '{-#' 'REWRITE' PragmaQNames '#-}'+      { RewritePragma (getRange ($1,$2,$3,$4)) (getRange $2) $3 }++ForeignPragma :: { Pragma }+ForeignPragma+  : '{-#' 'FOREIGN' string ForeignCode '#-}' { ForeignPragma (getRange ($1, $2, fst $3, $5)) (mkRString $3) (recoverLayout $4) }++CompilePragma :: { Pragma }+CompilePragma+  : '{-#' 'COMPILE' string PragmaQName PragmaStrings '#-}'+    { CompilePragma (getRange ($1,$2,fst $3,$4,$6)) (mkRString $3) $4 (unwords $5) }++StaticPragma :: { Pragma }+StaticPragma+  : '{-#' 'STATIC' PragmaQName '#-}'+    { StaticPragma (getRange ($1,$2,$3,$4)) $3 }++InlinePragma :: { Pragma }+InlinePragma+  : '{-#' 'INLINE' PragmaQName '#-}'+    { InlinePragma (getRange ($1,$2,$3,$4)) True $3 }++NoInlinePragma :: { Pragma }+NoInlinePragma+  : '{-#' 'NOINLINE' PragmaQName '#-}'+    { InlinePragma (getRange ($1,$2,$3,$4)) False $3 }++InjectivePragma :: { Pragma }+InjectivePragma+  : '{-#' 'INJECTIVE' PragmaQName '#-}'+    { InjectivePragma (getRange ($1,$2,$3,$4)) $3 }++DisplayPragma :: { Pragma }+DisplayPragma+  : '{-#' 'DISPLAY' string PragmaStrings '#-}' {%+      let (r, s) = $3 in+      parseDisplayPragma (fuseRange $1 $5) (iStart r) (unwords (s : $4)) }++EtaPragma :: { Pragma }+EtaPragma+  : '{-#' 'ETA' PragmaQName '#-}'+    { EtaPragma (getRange ($1,$2,$3,$4)) $3 }++NoTerminationCheckPragma :: { Pragma }+NoTerminationCheckPragma+  : '{-#' 'NO_TERMINATION_CHECK' '#-}'+    { TerminationCheckPragma (getRange ($1,$2,$3)) NoTerminationCheck }++NonTerminatingPragma :: { Pragma }+NonTerminatingPragma+  : '{-#' 'NON_TERMINATING' '#-}'+    { TerminationCheckPragma (getRange ($1,$2,$3)) NonTerminating }++TerminatingPragma :: { Pragma }+TerminatingPragma+  : '{-#' 'TERMINATING' '#-}'+    { TerminationCheckPragma (getRange ($1,$2,$3)) Terminating }++NonCoveringPragma :: { Pragma }+NonCoveringPragma+  : '{-#' 'NON_COVERING' '#-}'+    { NoCoverageCheckPragma (getRange ($1,$2,$3)) }++MeasurePragma :: { Pragma }+MeasurePragma+  : '{-#' 'MEASURE' PragmaName '#-}'+    { let r = getRange ($1, $2, $3, $4) in+      TerminationCheckPragma r (TerminationMeasure r $3) }++CatchallPragma :: { Pragma }+CatchallPragma+  : '{-#' 'CATCHALL' '#-}'+    { CatchallPragma (getRange ($1,$2,$3)) }++ImpossiblePragma :: { Pragma }+ImpossiblePragma+  : '{-#' 'IMPOSSIBLE' PragmaStrings '#-}'+    { ImpossiblePragma (getRange ($1,$2,$4)) $3 }++NoPositivityCheckPragma :: { Pragma }+NoPositivityCheckPragma+  : '{-#' 'NO_POSITIVITY_CHECK' '#-}'+    { NoPositivityCheckPragma (getRange ($1,$2,$3)) }++NoUniverseCheckPragma :: { Pragma }+NoUniverseCheckPragma+  : '{-#' 'NO_UNIVERSE_CHECK' '#-}'+    { NoUniverseCheckPragma (getRange ($1,$2,$3)) }++PolarityPragma :: { Pragma }+PolarityPragma+  : '{-#' 'POLARITY' PragmaName Polarities '#-}'+    { let (rs, occs) = unzip (reverse $4) in+      PolarityPragma (getRange ($1,$2,$3,rs,$5)) $3 occs }++WarningOnUsagePragma :: { Pragma }+WarningOnUsagePragma+  : '{-#' 'WARNING_ON_USAGE' PragmaQName literal '#-}'+  {%  case $4 of+        { Ranged r (LitString str) -> return $ WarningOnUsage (getRange ($1,$2,$3,r,$5)) $3 str+        ; _ -> parseError "Expected string literal"+        }+  }++WarningOnImportPragma :: { Pragma }+WarningOnImportPragma+  : '{-#' 'WARNING_ON_IMPORT' literal '#-}'+  {%  case $3 of+        { Ranged r (LitString str) -> return $ WarningOnImport (getRange ($1,$2,r,$4)) str+        ; _ -> parseError "Expected string literal"+        }+  }++-- Possibly empty list of polarities. Reversed.+Polarities :: { [(Range, Occurrence)] }+Polarities : {- empty -}          { [] }+           | Polarities Polarity  { $2 : $1 }++Polarity :: { (Range, Occurrence) }+Polarity : string {% polarity $1 }++{--------------------------------------------------------------------------+    Sequences of declarations+ --------------------------------------------------------------------------}++-- Possibly empty list of type signatures, with several identifiers allowed+-- for every signature.+TypeSignatures0 :: { [TypeSignature] }+TypeSignatures+    : vopen close    { [] }+    | TypeSignatures { List1.toList $1 }++-- Non-empty list of type signatures, with several identifiers allowed+-- for every signature.+TypeSignatures :: { List1 TypeSignature }+TypeSignatures+    : vopen TypeSignatures1 close   { List1.reverse $2 }++-- Inside the layout block.+TypeSignatures1 :: { List1 TypeSignature }+TypeSignatures1+    : TypeSignatures1 semi TypeSigs { List1.reverse $3 <> $1 }+    | TypeSigs                      { List1.reverse $1 }++-- A variant of TypeSignatures which uses ArgTypeSigs instead of+-- TypeSigs.+ArgTypeSignatures :: { List1 (Arg TypeSignature) }+ArgTypeSignatures+    : vopen ArgTypeSignatures1 close   { List1.reverse $2 }++-- Inside the layout block.+ArgTypeSignatures1 :: { List1 (Arg TypeSignature) }+ArgTypeSignatures1+    : ArgTypeSignatures1 semi ArgTypeSigs { List1.reverse $3 <> $1 }+    | ArgTypeSigs                         { List1.reverse $1 }++-- A variant of TypeSignatures which uses ArgTypeSigs instead of+-- TypeSigs.+ArgTypeSignaturesOrEmpty :: { [Arg TypeSignature] }+ArgTypeSignaturesOrEmpty+    : vopen ArgTypeSignatures0 close   { reverse $2 }++-- Inside the layout block.+ArgTypeSignatures0 :: { [Arg TypeSignature] }+ArgTypeSignatures0+    : ArgTypeSignatures0 semi ArgTypeSigs { reverse (List1.toList $3) ++ $1 }+    | ArgTypeSigs                         { reverse (List1.toList $1) }+    | {- empty -}                         { [] }++-- Record declarations, including an optional record constructor name.+RecordDeclarations :: { (RecordDirectives, [Declaration]) }+RecordDeclarations+    : vopen RecordDirectives close                    {% verifyRecordDirectives $2 <&> (,[]) }+    | vopen RecordDirectives semi Declarations1 close {% verifyRecordDirectives $2 <&> (, List1.toList $4) }+    | vopen Declarations1 close                       { (emptyRecordDirectives, List1.toList $2) }+++RecordDirectives :: { [RecordDirective] }+RecordDirectives+    : {- empty -}                           { [] }+    | RecordDirectives semi RecordDirective { $3 : $1 }+    | RecordDirective                       { [$1] }++RecordDirective :: { RecordDirective }+RecordDirective+    : RecordConstructorName { uncurry Constructor $1 }+    | RecordInduction       { Induction $1 }+    | RecordEta             { Eta $1 }+    | RecordPatternMatching { PatternOrCopattern $1 }++RecordEta :: { Ranged HasEta0 }+RecordEta+    : 'eta-equality'    { Ranged (getRange $1) YesEta }+    | 'no-eta-equality' { Ranged (getRange $1) (NoEta ()) }++-- Directive 'pattern' if a decision between matching on constructor/record pattern+-- or copattern matching is needed.+-- Such decision is only needed for 'no-eta-equality' records.+-- But eta could be turned off automatically, thus, we do not bundle this+-- with the 'no-eta-equality' declaration.+-- Nor with the 'constructor' declaration, since it applies also to+-- the record pattern.+RecordPatternMatching :: { Range }+RecordPatternMatching+    : 'pattern'     { getRange $1 }++-- Declaration of record as 'inductive' or 'coinductive'.+RecordInduction :: { Ranged Induction }+RecordInduction+    : 'inductive'   { Ranged (getRange $1) Inductive   }+    | 'coinductive' { Ranged (getRange $1) CoInductive }++-- Arbitrary declarations+Declarations :: { List1 Declaration }+Declarations+    : vopen Declarations1 close { $2 }++-- Arbitrary declarations (possibly empty)+Declarations0 :: { [Declaration] }+Declarations0+    : vopen close  { [] }+    | Declarations { List1.toList $1 }++Declarations1 :: { List1 Declaration }+Declarations1+    : Declaration semi Declarations1 { $1 <> $3 }+    | Declaration vsemi              { $1 } -- #3046+    | Declaration                    { $1 }++TopDeclarations :: { [Declaration] }+TopDeclarations+  : {- empty -}   { [] }+  | Declarations1 { List1.toList $1 }++{++{--------------------------------------------------------------------------+    Parsers+ --------------------------------------------------------------------------}++-- | Parse the token stream. Used by the TeX compiler.+tokensParser :: Parser [Token]++-- | Parse an expression. Could be used in interactions.+exprParser :: Parser Expr++-- | Parse an expression followed by a where clause. Could be used in interactions.+exprWhereParser :: Parser ExprWhere++-- | Parse a module.+moduleParser :: Parser Module+++{--------------------------------------------------------------------------+    Happy stuff+ --------------------------------------------------------------------------}++-- | Required by Happy.+happyError :: Parser a+happyError = parseError "Parse error"+++{--------------------------------------------------------------------------+    Utility functions+ --------------------------------------------------------------------------}++-- | Grab leading OPTIONS pragmas.+takeOptionsPragmas :: [Declaration] -> Module+takeOptionsPragmas = uncurry Mod . spanJust (\ d -> case d of+  Pragma p@OptionsPragma{} -> Just p+  _                        -> Nothing)++-- | 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.++    -- Case 1: Regular file layout: imports followed by one module. Nothing to do.+    (ds0, [ Module{} ]) -> ds++    -- 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 m tel [] : ds2) -> ds0 ++ [Module r m tel 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]++    -- 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 (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++-- | Create a name from a string.++mkName :: (Interval, String) -> Parser Name+mkName (i, s) = do+    let xs = C.stringNameParts s+    mapM_ isValidId xs+    unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores"+    return $ Name (getRange i) InScope xs+    where+        isValidId Hole   = return ()+        isValidId (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+            ParseOk _ TokId{}  -> return ()+            ParseFailed{}      -> parseError err+            ParseOk _ TokEOF{} -> parseError err+            ParseOk _ t   -> parseError . ((err ++ " because it is ") ++) $ case t of+              TokId{}       -> __IMPOSSIBLE__+              TokQId{}      -> __IMPOSSIBLE__ -- "qualified"+              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"+                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        -> __IMPOSSIBLE__ -- "used for pragmas"+                SymClosePragma       -> __IMPOSSIBLE__ -- "used for pragmas"+                SymEllipsis          -> "used for function clauses"+                SymDotDot            -> __IMPOSSIBLE__ -- "a modality"+                SymEndComment        -> "the end-of-comment brace"+              TokString{}   -> __IMPOSSIBLE__+              TokTeX{}      -> __IMPOSSIBLE__  -- used by the LaTeX backend only+              TokMarkup{}   -> __IMPOSSIBLE__  -- ditto+              TokComment{}  -> __IMPOSSIBLE__+              TokDummy{}    -> __IMPOSSIBLE__+              TokEOF{}      -> __IMPOSSIBLE__++        -- we know that there are no two Ids in a row+        alternating (Hole :| Hole : _) = False+        alternating (_    :| x   : xs) = alternating $ x :| xs+        alternating (_    :|       []) = True++-- | Create a qualified name from a list of strings+mkQName :: [(Interval, String)] -> Parser QName+mkQName ss = do+    xs <- mapM mkName ss+    return $ foldr Qual (QName $ last xs) (init xs)++mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> NamedArg Binder+mkDomainFree_ f p n = f $ defaultNamedArg $ Binder p $ mkBoundName_ n++mkRString :: (Interval, String) -> RString+mkRString (i, s) = Ranged (getRange i) s++-- | Create a qualified name from a string (used in pragmas).+--   Range of each name component is range of whole string.+--   TODO: precise ranges!++pragmaQName :: (Interval, String) -> Parser QName+pragmaQName (r, s) = do+  let ss = chopWhen (== '.') s+  mkQName $ map (r,) ss++mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName)+mkNamedArg x y = do+  lbl <- case x of+           Nothing        -> return $ Just $ WithOrigin UserWritten $ unranged "_"+           Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x+           _              -> parseError "expected unqualified variable name"+  var <- case y of+           Left (QName y) -> return $ mkBoundName y noFixity'+           Right r        -> return $ mkBoundName (noName r) noFixity'+           _              -> parseError "expected unqualified variable name"+  return $ defaultArg $ Named lbl var++-- | Polarity parser.++polarity :: (Interval, String) -> Parser (Range, Occurrence)+polarity (i, s) =+  case s of+    "_"  -> ret Unused+    "++" -> ret StrictPos+    "+"  -> ret JustPos+    "-"  -> ret JustNeg+    "*"  -> ret Mixed+    _    -> parseError $ "Not a valid polarity: " ++ s+  where+  ret x = return (getRange i, x)++recoverLayout :: [(Interval, String)] -> String+recoverLayout [] = ""+recoverLayout xs@((i, _) : _) = go (iStart i) xs+  where+    c0 = posCol (iStart i)++    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 }+      | l1 < l2  = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' '+      | l1 == l2 = List.genericReplicate (c2 - c1) ' '++ensureUnqual :: QName -> Parser Name+ensureUnqual (QName x) = return x+ensureUnqual q@Qual{}  = parseError' (rStart' $ getRange q) "Qualified name not allowed here"++-- | Match a particular name.+isName :: String -> (Interval, String) -> Parser ()+isName s (_,s')+    | s == s'   = return ()+    | otherwise = parseError $ "expected " ++ s ++ ", found " ++ s'++-- Lambinds++-- | Result of parsing @LamBinds@.+data LamBinds' a = LamBinds+  { lamBindings   :: a             -- ^ A number of domain-free or typed bindings or record patterns.+  , absurdBinding :: Maybe Hiding  -- ^ Followed by possibly a final absurd pattern.+  } deriving (Functor)+type LamBinds = LamBinds' [LamBinding]++mkAbsurdBinding :: Hiding -> LamBinds+mkAbsurdBinding = LamBinds [] . Just++mkLamBinds :: a -> LamBinds' a+mkLamBinds bs = LamBinds bs Nothing++-- | Build a forall pi (forall x y z -> ...)+forallPi :: List1 LamBinding -> Expr -> Expr+forallPi bs e = Pi (fmap addType bs) e++-- | Converts lambda bindings to typed bindings.+addType :: LamBinding -> TypedBinding+addType (DomainFull b) = b+addType (DomainFree x) = TBind r (singleton x) $ Underscore r Nothing+  where r = getRange x++-- | Returns the value of the first erasure attribute, if any, or else+-- the default value of type 'Erased'.+--+-- Raises warnings for all attributes except for erasure attributes,+-- and for multiple erasure attributes.++onlyErased+  :: [Attr]  -- ^ The attributes, in reverse order.+  -> Parser Erased+onlyErased as = do+  es <- catMaybes <$> mapM onlyErased' (reverse as)+  case es of+    []     -> return defaultErased+    [e]    -> return e+    e : es -> do+      parseWarning $ MultipleAttributes (getRange es) (Just "erasure")+      return e+  where+  onlyErased' a = case theAttr a of+    RelevanceAttribute{} -> unsup "Relevance"+    CohesionAttribute{}  -> unsup "Cohesion"+    LockAttribute{}      -> unsup "Lock"+    TacticAttribute{}    -> unsup "Tactic"+    QuantityAttribute q  -> case q of+      Quantity1{} -> unsup "Linearity"+      Quantity0 o -> return $ Just (Erased    o)+      Quantityω o -> return $ Just (NotErased o)+    where+    unsup s = do+      parseWarning $ UnsupportedAttribute (attrRange a) (Just s)+      return Nothing++-- | Constructs extended lambdas.++extLam+  :: Range            -- ^ The range of the lambda symbol and @where@ or+                      --   the braces.+  -> [Attr]           -- ^ The attributes in reverse order.+  -> List1 LamClause  -- ^ The clauses in reverse order.+  -> Parser Expr+extLam symbolRange attrs cs = do+  e <- onlyErased attrs+  let cs' = List1.reverse cs+  return $ ExtendedLam (getRange (symbolRange, e, cs')) e cs'++-- | Constructs extended or absurd lambdas.++extOrAbsLam+  :: Range   -- ^ The range of the lambda symbol.+  -> [Attr]  -- ^ The attributes, in reverse order.+  -> Either ([LamBinding], Hiding) (List1 Expr)+  -> Parser Expr+extOrAbsLam lambdaRange attrs cs = case cs of+  Right es -> do+    -- It is of the form @\ { p1 ... () }@.+    e  <- onlyErased attrs+    cl <- mkAbsurdLamClause False es+    return $ ExtendedLam (getRange (lambdaRange, e, es)) e $ singleton cl+  Left (bs, h) -> do+    mapM_ (\a -> parseWarning $+                   UnsupportedAttribute (attrRange a) Nothing)+          (reverse attrs)+    List1.ifNull bs+      {-then-} (return $ AbsurdLam r h)+      {-else-} $ \ bs -> return $ Lam r bs (AbsurdLam r h)+    where+    r = fuseRange lambdaRange bs++-- | Interpret an expression as a list of names and (not parsed yet) as-patterns++exprAsTele :: Expr -> List1 Expr+exprAsTele (RawApp _ es) = List2.toList1 es+exprAsTele e             = singleton e++exprAsNamesAndPatterns :: Expr -> Maybe (List1 (Name, Maybe Expr))+exprAsNamesAndPatterns = mapM exprAsNameAndPattern . exprAsTele++exprAsNameAndPattern :: Expr -> Maybe (Name, Maybe Expr)+exprAsNameAndPattern (Ident (QName x)) = Just (x, Nothing)+exprAsNameAndPattern (Underscore r _)  = Just (setRange r simpleHole, Nothing)+exprAsNameAndPattern (As _ n e)        = Just (n, Just e)+exprAsNameAndPattern (Paren r e)       = Just (setRange r simpleHole, Just e)+exprAsNameAndPattern _                 = Nothing++-- interpret an expression as name or list of hidden / instance names+exprAsNameOrHiddenNames :: Expr -> Maybe (List1 (NamedArg (Name, Maybe Expr)))+exprAsNameOrHiddenNames = \case+  HiddenArg _ (Named Nothing e) ->+    fmap (hide . defaultNamedArg) <$> exprAsNamesAndPatterns e+  InstanceArg _ (Named Nothing e) ->+    fmap (makeInstance . defaultNamedArg) <$> exprAsNamesAndPatterns e+  e ->+    singleton . defaultNamedArg <$> exprAsNameAndPattern e++boundNamesOrAbsurd :: List1 Expr -> Parser (Either (List1 (NamedArg Binder)) (List1 Expr))+boundNamesOrAbsurd es+  | any isAbsurd es = return $ Right es+  | otherwise       =+    case mapM exprAsNameAndPattern es of+        Nothing   -> parseError $ "expected sequence of bound identifiers"+        Just good -> fmap Left $ forM good $ \ (n, me) -> do+                       p <- traverse exprToPattern me+                       return (defaultNamedArg (Binder p (mkBoundName_ n)))++  where++    isAbsurd :: Expr -> Bool+    isAbsurd (Absurd _)                  = True+    isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e+    isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e+    isAbsurd (Paren _ e)                 = isAbsurd e+    isAbsurd (As _ _ e)                  = isAbsurd e+    isAbsurd (RawApp _ es)               = any isAbsurd es+    isAbsurd _                           = False++-- | Match a pattern-matching "assignment" statement @p <- e@+exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr))+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+      [] ->+        -- Andreas, 2021-05-06, issue #5365+        -- Handle pathological cases like @do ←@ and @do x ←@.+        case (es1, es2) of+          (e1:rest1, e2:rest2) -> do+            p <- exprToPattern $ rawApp $ e1 :| rest1+            pure $ Just (p, getRange arr, rawApp (e2 :| rest2))+          _ -> parseError' (rStart' $ getRange e) $ "Incomplete binding " ++ prettyShow e+  where+    isLeftArrow (Ident (QName (Name _ _ (Id arr :| [])))) = arr `elem` ["<-", "←"]+    isLeftArrow _ = False+exprToAssignment _ = pure Nothing++-- | Build a with-block+buildWithBlock ::+  [Either RewriteEqn (List1 (Named Name Expr))] ->+  Parser ([RewriteEqn], [Named Name Expr])+buildWithBlock rees = case groupByEither rees of+  (Left rs : rest) -> (List1.toList rs,) <$> finalWith rest+  rest             -> ([],) <$> finalWith rest++  where++    finalWith :: (HasRange a, HasRange b) =>+                 [Either (List1 a) (List1 (List1 b))] -> Parser [b]+    finalWith []             = pure $ []+    finalWith [Right ees]    = pure $ List1.toList $ sconcat ees+    finalWith (Right{} : tl) = parseError' (rStart' $ getRange tl)+      "Cannot use rewrite / pattern-matching with after a with-abstraction."++-- | Build a with-statement+buildWithStmt :: List1 (Named Name Expr) ->+                 Parser [Either RewriteEqn (List1 (Named Name Expr))]+buildWithStmt nes = do+  ws <- mapM buildSingleWithStmt (List1.toList nes)+  let rws = groupByEither ws+  pure $ map (first (Invert ())) rws++buildSingleWithStmt ::+  Named Name Expr ->+  Parser (Either (Named Name (Pattern, Expr)) (Named Name Expr))+buildSingleWithStmt e = do+  mpatexpr <- exprToAssignment (namedThing e)+  pure $ case mpatexpr of+    Just (pat, _, expr) -> Left ((pat, expr) <$ e)+    Nothing             -> Right e++fromWithApp :: Expr -> List1 Expr+fromWithApp = \case+  WithApp _ e es -> e :| es+  e              -> singleton e++-- | Build a do-statement+defaultBuildDoStmt :: Expr -> [LamClause] -> Parser DoStmt+defaultBuildDoStmt e (_ : _) = parseError' (rStart' $ getRange e) "Only pattern matching do-statements can have where clauses."+defaultBuildDoStmt e []      = pure $ DoThen e++buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt+buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds+buildDoStmt e@(RawApp r _)    cs = do+  mpatexpr <- exprToAssignment e+  case mpatexpr of+    Just (pat, r, expr) -> pure $ DoBind r pat expr cs+    Nothing -> defaultBuildDoStmt e cs+buildDoStmt e cs = defaultBuildDoStmt e cs+++-- | Extract record directives+extractRecordDirectives :: [Declaration] -> Parser (RecordDirectives, [Declaration])+extractRecordDirectives ds = do+  let (dirs, rest) = spanJust isRecordDirective ds+  dir <- verifyRecordDirectives dirs+  pure (dir, rest)++-- | Check for duplicate record directives.+verifyRecordDirectives :: [RecordDirective] -> Parser RecordDirectives+verifyRecordDirectives ds+  | null rs   = return (RecordDirectives (listToMaybe is) (listToMaybe es) (listToMaybe ps) (listToMaybe cs))+      -- Here, all the lists is, es, cs, ps are at most singletons.+  | otherwise = parseErrorRange (head rs) $ unlines $ "Repeated record directives at:" : map prettyShow rs+  where+  errorFromList []  = []+  errorFromList [x] = []+  errorFromList xs  = map getRange xs+  rs  = List.sort $ concat [ errorFromList is, errorFromList es', errorFromList cs, errorFromList ps ]+  es  = map rangedThing es'+  is  = [ i      | Induction i          <- ds ]+  es' = [ e      | Eta e                <- ds ]+  cs  = [ (c, i) | Constructor c i      <- ds ]+  ps  = [ r      | PatternOrCopattern r <- ds ]+++-- | Breaks up a string into substrings. Returns every maximal+-- subsequence of zero or more characters distinct from @'.'@.+--+-- > splitOnDots ""         == [""]+-- > splitOnDots "foo.bar"  == ["foo", "bar"]+-- > splitOnDots ".foo.bar" == ["", "foo", "bar"]+-- > splitOnDots "foo.bar." == ["foo", "bar", ""]+-- > splitOnDots "foo..bar" == ["foo", "", "bar"]+splitOnDots :: String -> [String]+splitOnDots ""        = [""]+splitOnDots ('.' : s) = [] : splitOnDots s+splitOnDots (c   : s) = case splitOnDots s of+  p : ps -> (c : p) : ps+++-- | Returns 'True' iff the name is a valid Haskell (hierarchical)+-- module name.+validHaskellModuleName :: String -> Bool+validHaskellModuleName = all ok . splitOnDots+  where+  -- Checks if a dot-less module name is well-formed.+  ok :: String -> Bool+  ok []      = False+  ok (c : s) =+    isUpper c &&+    all (\c -> isLower c || c == '_' ||+               isUpper c ||+               generalCategory c == DecimalNumber ||+               c == '\'')+        s++{--------------------------------------------------------------------------+    Patterns+ --------------------------------------------------------------------------}++-- | Turn an expression into a left hand side.+exprToLHS :: Expr -> Parser ([RewriteEqn] -> [WithExpr] -> LHS)+exprToLHS e = LHS <$> exprToPattern e++-- | Turn an expression into a pattern. Fails if the expression is not a+--   valid pattern.+exprToPattern :: Expr -> Parser Pattern+exprToPattern e = case C.isPattern e of+  Nothing -> parseErrorRange e $ "Not a valid pattern: " ++ prettyShow e+  Just p  -> pure p++opAppExprToPattern :: OpApp Expr -> Parser Pattern+opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern"+opAppExprToPattern (Ordinary e) = exprToPattern e++-- | Turn an expression into a name. Fails if the expression is not a+--   valid identifier.+exprToName :: Expr -> Parser Name+exprToName (Ident (QName x)) = return x+exprToName e = parseErrorRange e $ "Not a valid identifier: " ++ prettyShow e++isEqual :: Expr -> Maybe (Expr, Expr)+isEqual = \case+    Equal _ a b -> Just (a, b)+    _           -> Nothing++-- | When given expression is @e1 = e2@, turn it into a named expression.+--   Call this inside an implicit argument @{e}@ or @{{e}}@, where+--   an equality must be a named argument (rather than a cubical partial match).+maybeNamed :: Expr -> Parser (Named_ Expr)+maybeNamed e =+  case isEqual e of+    Nothing       -> return $ unnamed e+    Just (e1, e2) -> do+      let succeed x = return $ named (WithOrigin UserWritten $ Ranged (getRange e1) x) e2+      case e1 of+        Ident (QName x) -> succeed $ nameToRawName x+        -- We could have the following, but names of arguments cannot be _.+        -- Underscore{}    -> succeed $ "_"+        _ -> parseErrorRange e $ "Not a valid named argument: " ++ prettyShow e++patternSynArgs :: [NamedArg Binder] -> Parser [Arg Name]+patternSynArgs = mapM pSynArg+  where+    pSynArg x+      | let h = getHiding x, h `notElem` [Hidden, NotHidden] =+          abort $ prettyShow h ++ " arguments not allowed to pattern synonyms"+      | not (isRelevant x) =+          abort "Arguments to pattern synonyms must be relevant"+      | Just p <- binderPattern (namedArg x) =+          abort "Arguments to pattern synonyms cannot be patterns themselves"+      | otherwise = return $ fmap (boundName . binderName . namedThing) x+      where+      abort s = parseError $+        "Illegal pattern synonym argument  " ++ prettyShow x ++ "\n" +++        "(" ++ s ++ ".)"++mkLamClause+  :: Bool   -- ^ Catch-all?+  -> [Expr] -- ^ Possibly empty list of patterns.+  -> RHS+  -> Parser LamClause+mkLamClause catchAll es rhs = mapM exprToPattern es <&> \ ps ->+  LamClause{ lamLHS = ps, lamRHS = rhs, lamCatchAll = catchAll }++mkAbsurdLamClause :: Bool -> List1 Expr -> Parser LamClause+mkAbsurdLamClause catchAll es = mkLamClause catchAll (List1.toList es) AbsurdRHS++parsePanic s = parseError $ "Internal parser error: " ++ s ++ ". Please report this as a bug."++{- RHS or type signature -}++data RHSOrTypeSigs+ = JustRHS RHS+ | TypeSigsRHS Expr+ deriving Show++patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name))+patternToNames = \case+    IdentP (QName i)         -> return $ singleton $ (defaultArgInfo, i)+    WildP r                  -> return $ singleton $ (defaultArgInfo, C.noName r)+    DotP _ (Ident (QName i)) -> return $ singleton $ (setRelevance Irrelevant defaultArgInfo, i)+    RawAppP _ ps             -> sconcat . List2.toList1 <$> mapM patternToNames ps+    p                        -> parseError $+      "Illegal name in type signature: " ++ prettyShow p++funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS)+                    -> [Either RewriteEqn (List1 (Named Name Expr))]+                    -> RHSOrTypeSigs+                    -> WhereClause -> Parser (List1 Declaration)+funClauseOrTypeSigs attrs lhs' with mrhs wh = do+  (rs , es) <- buildWithBlock with+  let lhs = lhs' rs (map (fmap observeModifiers) es)+  -- traceShowM lhs+  case mrhs of+    JustRHS rhs   -> do+      unless (null attrs) $ parseErrorRange attrs $ "A function clause cannot have attributes"+      return $ singleton $ FunClause lhs rhs wh False+    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+          info <- applyAttrs attrs info+          return $ typeSig info (getTacticAttr attrs) x e+      _ -> parseError "A type signature cannot have a where clause"++parseDisplayPragma :: Range -> Position -> String -> 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) ->+      return $ DisplayPragma r lhs rhs+    _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."++typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration+typeSig i tac n e = TypeSig i tac n (Generalized e)++-- * Attributes++-- | Parsed attribute.++data Attr = Attr+  { attrRange :: Range       -- ^ Range includes the @.+  , attrName  :: String      -- ^ Concrete, user written attribute for error reporting.+  , theAttr   :: Attribute   -- ^ Parsed attribute.+  }++instance HasRange Attr where+  getRange = attrRange++instance SetRange Attr where+  setRange r (Attr _ x a) = Attr r x a++-- | Parse an attribute.+toAttribute :: Expr -> Parser Attr+toAttribute x = maybe failure (return . Attr (getRange x) y) $ exprToAttribute x+  where+  y = prettyShow x+  failure = parseErrorRange x $ "Unknown attribute: " ++ y++-- | 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.+applyAttr :: (LensAttribute a) => Attr -> a -> Parser a+applyAttr attr@(Attr r x a) = maybe failure return . setPristineAttribute a+  where+  failure = errorConflictingAttribute attr++-- | 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+  checkForUniqueAttribute (isJust . isQuantityAttribute ) attrs+  checkForUniqueAttribute (isJust . isRelevanceAttribute) attrs+  checkForUniqueAttribute (isJust . isTacticAttribute)    attrs+  foldM (flip applyAttr) arg attrs++applyAttrs1 :: LensAttribute a => List1 Attr -> a -> Parser a+applyAttrs1 = applyAttrs . List1.toList++-- | Set the tactic attribute of a binder+setTacticAttr :: List1 Attr -> NamedArg Binder -> NamedArg Binder+setTacticAttr as = updateNamedArg $ fmap $ \ b ->+  case getTacticAttr $ List1.toList as of     Just t  -> b { bnameTactic = Just t }     Nothing -> b

src/full/Agda/Syntax/Parser/StringLiterals.hs view

@@ -5,8 +5,11 @@     ( litString, litChar     ) where +import Data.Bifunctor import Data.Char+import qualified Data.Text as T +import Agda.Syntax.Common (pattern Ranged) import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad import Agda.Syntax.Parser.Tokens@@ -14,16 +17,14 @@ import Agda.Syntax.Position import Agda.Syntax.Literal -import Agda.Utils.Tuple  ( (-*-) )- {--------------------------------------------------------------------------     Exported actions  --------------------------------------------------------------------------}  -- | Lex a string literal. Assumes that a double quote has been lexed. litString :: LexAction Token-litString = stringToken '"' (\i s ->-              return $ TokLiteral $ LitString (getRange i) s)+litString = stringToken '"' $ \ i s ->+  return $ TokLiteral $ Ranged (getRange i) $ LitString $ T.pack s  {-| Lex a character literal. Assumes that a single quote has been lexed.  A     character literal is lexed in exactly the same way as a string literal.@@ -32,11 +33,9 @@     the other hand it will only be inefficient if there is a lexical error. -} litChar :: LexAction Token-litChar = stringToken '\'' $ \i s ->-            do  case s of-                    [c] -> return $ TokLiteral $ LitChar (getRange i) c-                    _   -> lexError-                            "character literal must contain a single character"+litChar = stringToken '\'' $ \ i -> \case+  [c] -> return $ TokLiteral $ Ranged (getRange i) $ LitChar c+  _   -> lexError "character literal must contain a single character"   {--------------------------------------------------------------------------@@ -59,7 +58,7 @@ --   character argument is the delimiter (@\"@ for strings and @\'@ for --   characters). stringToken :: Char -> (Interval -> String -> Parser tok) -> LexAction tok-stringToken del mkTok inp inp' n =+stringToken del mkTok = LexAction $ \ inp inp' n ->     do  setLastPos (backupPos $ lexPos inp')         setLexInput inp'         -- TODO: Should setPrevToken be run here? Compare with@@ -130,7 +129,7 @@             c ->                 -- Try to match the input (starting with c) against the                 -- silly escape codes.-                do  esc <- match' c (map (id -*- return) sillyEscapeChars)+                do  esc <- match' c (map (second return) sillyEscapeChars)                                     (lookAheadError "bad escape code")                     sync                     return esc

src/full/Agda/Syntax/Parser/Tokens.hs view

@@ -5,16 +5,17 @@     , Symbol(..)     ) where -import Agda.Syntax.Literal (Literal)+import Agda.Syntax.Literal (RLiteral) import Agda.Syntax.Position  data Keyword         = KwLet | KwIn | KwWhere | KwData | KwCoData | KwDo-        | KwPostulate | KwMutual | KwAbstract | KwPrivate | KwInstance+        | KwPostulate | KwAbstract | KwPrivate | KwInstance+        | KwInterleaved | KwMutual         | KwOverlap         | KwOpen | KwImport | KwModule | KwPrimitive | KwMacro         | KwInfix | KwInfixL | KwInfixR | KwWith | KwRewrite-        | KwSet | KwProp | KwForall | KwRecord | KwConstructor | KwField+        | KwForall | KwRecord | KwConstructor | KwField         | KwInductive | KwCoInductive         | KwEta | KwNoEta         | KwHiding | KwUsing | KwRenaming | KwTo | KwPublic@@ -36,9 +37,26 @@         | KwNO_UNIVERSE_CHECK     deriving (Eq, Show) +-- | Unconditional layout keywords.+--+-- Some keywords introduce layout only in certain circumstances,+-- these are not included here.+-- layoutKeywords :: [Keyword] layoutKeywords =-    [ KwLet, KwWhere, KwDo, KwPostulate, KwMutual, KwAbstract, KwPrivate, KwInstance, KwMacro, KwPrimitive, KwField, KwVariable ]+    [ KwAbstract+    , KwDo+    , KwField+    , KwInstance+    , KwLet+    , KwMacro+    , KwMutual+    , KwPostulate+    , KwPrimitive+    , KwPrivate+    , KwVariable+    , KwWhere+    ]  data Symbol         = SymDot | SymSemi | SymVirtualSemi | SymBar@@ -62,13 +80,12 @@                         -- Non-empty namespace. The intervals for                         -- "A.B.x" correspond to "A.", "B." and "x".           -- Literals-        | TokLiteral    Literal+        | TokLiteral    RLiteral           -- Special symbols         | TokSymbol Symbol Interval           -- Other tokens-        | TokString (Interval, String)  -- arbitrary string, used in pragmas-        | TokSetN (Interval, Integer)-        | TokPropN (Interval, Integer)+        | TokString (Interval, String)+            -- ^ Arbitrary string (not enclosed in double quotes), used in pragmas.         | TokTeX (Interval, String)         | TokMarkup (Interval, String)         | TokComment (Interval, String)@@ -84,8 +101,6 @@   getRange (TokLiteral lit)    = getRange lit   getRange (TokSymbol _ i)     = getRange i   getRange (TokString (i, _))  = getRange i-  getRange (TokSetN (i, _))    = getRange i-  getRange (TokPropN (i, _))   = getRange i   getRange (TokTeX (i, _))     = getRange i   getRange (TokMarkup (i, _))  = getRange i   getRange (TokComment (i, _)) = getRange i

src/full/Agda/Syntax/Position.hs view

@@ -1,8 +1,3 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}- {-| Position information for syntax. Crucial for giving good error messages. -} @@ -67,31 +62,32 @@  import Prelude hiding ( null ) +import Control.DeepSeq import Control.Monad.Writer (runWriter, tell) -import Data.Foldable (Foldable) import qualified Data.Foldable as Fold import Data.Function import Data.Int import Data.List hiding (null)-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Traversable (Traversable) import Data.Data (Data) import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import Data.Semigroup (Semigroup(..)) import Data.Void  import GHC.Generics (Generic)  import Agda.Utils.FileName 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.Null+import Agda.Utils.Permutation import Agda.Utils.Pretty  import Agda.Utils.Impossible@@ -119,7 +115,7 @@   , posCol  :: !Int32     -- ^ Column number, counting from 1.   }-  deriving (Data, Functor, Foldable, Traversable, Generic)+  deriving (Show, Data, Functor, Foldable, Traversable, Generic)  positionInvariant :: Position' a -> Bool positionInvariant p =@@ -139,15 +135,27 @@ type Position            = Position' SrcFile type PositionWithoutFile = Position' () +instance NFData Position where+  rnf = (`seq` ())++instance NFData PositionWithoutFile where+  rnf = (`seq` ())+ -- | An interval. The @iEnd@ position is not included in the interval. -- -- Note the invariant which intervals have to satisfy: 'intervalInvariant'. data Interval' a = Interval { iStart, iEnd :: !(Position' a) }-  deriving (Data, Eq, Ord, Functor, Foldable, Traversable, Generic)+  deriving (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic)  type Interval            = Interval' SrcFile type IntervalWithoutFile = Interval' () +instance NFData Interval where+  rnf = (`seq` ())++instance NFData IntervalWithoutFile where+  rnf = (`seq` ())+ intervalInvariant :: Ord a => Interval' a -> Bool intervalInvariant i =   all positionInvariant [iStart i, iEnd i]@@ -188,16 +196,31 @@   = NoRange   | Range !a (Seq IntervalWithoutFile)   deriving-    (Data, Eq, Ord, Functor, Foldable, Traversable, Generic)+    (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic)  type Range = Range' SrcFile +instance NFData a => NFData (Range' a)+ instance Null (Range' a) where   null NoRange = True   null Range{} = False    empty = NoRange +instance Semigroup a => Semigroup (Range' a) where+  NoRange <> r = r+  r <> NoRange = r+  Range f is <> Range f' is' = Range (f <> f') (is <> is')++instance Semigroup a => Monoid (Range' a) where+  mempty  = empty+  mappend = (<>)++-- | To get @'Semigroup' 'Range'@, we need a semigroup instance for 'AbsolutePath'.+instance Semigroup AbsolutePath where+  f <> f' = if f == f' then f else __IMPOSSIBLE__+ -- | The intervals that make up the range. The intervals are -- consecutive and separated ('consecutiveAndSeparated'). rangeIntervals :: Range' a -> [IntervalWithoutFile]@@ -250,9 +273,12 @@   deriving (Eq, Ord, HasRange, SetRange, KillRange)  -- | Things that have a range are instances of this class.-class HasRange t where-    getRange :: t -> Range+class HasRange a where+  getRange :: a -> Range +  default getRange :: (Foldable t, HasRange b, t b ~ a) => a -> Range+  getRange = Fold.foldr fuseRange noRange+ instance HasRange Interval where     getRange i =       intervalToRange (srcFile (iStart i))@@ -269,13 +295,13 @@  -- | Precondition: The ranges of the list elements must point to the -- same file (or be empty).-instance HasRange a => HasRange [a] where-    getRange = foldr fuseRange noRange+instance HasRange a => HasRange [a]  -- | Precondition: The ranges of the list elements must point to the -- same file (or be empty).-instance HasRange a => HasRange (NonEmpty a) where-    getRange = Fold.foldr fuseRange noRange+instance HasRange a => HasRange (List1 a)+instance HasRange a => HasRange (List2 a)+instance HasRange a => HasRange (Maybe a)  -- | Precondition: The ranges of the tuple elements must point to the -- same file (or be empty).@@ -307,31 +333,31 @@ instance (HasRange a, HasRange b, HasRange c, HasRange d, HasRange e, HasRange f, HasRange g) => HasRange (a,b,c,d,e,f,g) where     getRange (x,y,z,w,v,u,t) = getRange (x,(y,(z,(w,(v,(u,t)))))) -instance HasRange a => HasRange (Maybe a) where-    getRange = maybe noRange getRange- instance (HasRange a, HasRange b) => HasRange (Either a b) where     getRange = either getRange getRange  -- | If it is also possible to set the range, this is the class. -- --   Instances should satisfy @'getRange' ('setRange' r x) == r@.-class HasRange t => SetRange t where-  setRange :: Range -> t -> t+class HasRange a => SetRange a where+  setRange :: Range -> a -> a +  default setRange :: (Functor f, SetRange b, f b ~ a) => Range -> a -> a+  setRange = fmap . setRange+ instance SetRange Range where   setRange = const -instance SetRange a => SetRange [a] where-  setRange r = fmap $ setRange r--instance SetRange a => SetRange (Maybe a) where-  setRange r = fmap $ setRange r+instance SetRange a => SetRange [a]+instance SetRange a => SetRange (Maybe a)  -- | Killing the range of an object sets all range information to 'noRange'. class KillRange a where   killRange :: KillRangeT a +  default killRange :: (Functor f, KillRange b, f b ~ a) => KillRangeT a+  killRange = fmap killRange+ type KillRangeT a = a -> a  -- | Remove ranges in keys and values of a map.@@ -479,19 +505,22 @@ instance KillRange Integer where   killRange = id -instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a] where-  killRange = map killRange--instance KillRange a => KillRange (NonEmpty a) where-  killRange = fmap killRange+instance KillRange Permutation where+  killRange = id  -- | Overlaps with @KillRange [a]@. instance {-# OVERLAPPING #-} KillRange String where   killRange = id -instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) where-  killRange = fmap killRange+instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a]+instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) +instance KillRange a => KillRange (Drop a)+instance KillRange a => KillRange (List1 a)+instance KillRange a => KillRange (List2 a)+instance KillRange a => KillRange (Maybe a)+instance KillRange a => KillRange (Strict.Maybe a)+ instance {-# OVERLAPPABLE #-} (Ord a, KillRange a) => KillRange (Set a) where   killRange = Set.map killRange @@ -506,66 +535,11 @@          KillRange (a, b, c, d) where   killRange (x, y, z, u) = killRange4 (,,,) x y z u -instance KillRange a => KillRange (Maybe a) where-  killRange = fmap killRange--instance KillRange a => KillRange (Strict.Maybe a) where-  killRange = fmap killRange- instance (KillRange a, KillRange b) => KillRange (Either a b) where   killRange (Left  x) = Left  $ killRange x   killRange (Right x) = Right $ killRange x  --------------------------------------------------------------------------- Showing----------------------------------------------------------------------------- TODO: 'Show' should output Haskell-parseable representations.--- The following instances are deprecated, and Pretty should be used--- instead.  Later, simply derive Show for these types.---- ASR (02 December 2014). This instance is not used anymore (module--- the test suite) when reporting errors. See Issue 1293.-instance Show a => Show (Position' (Strict.Maybe a)) where-  show (Pn (Strict.Just f) _ l c) = show f ++ ":" ++-                                    show l ++ "," ++ show c-  show (Pn Strict.Nothing  _ l c) = show l ++ "," ++ show c--instance Show PositionWithoutFile where-  show p = show (p { srcFile = Strict.Nothing } :: Position)--instance Show IntervalWithoutFile where-  show (Interval s e) = start ++ "-" ++ end-    where-      sl = posLine s-      el = posLine e-      sc = posCol s-      ec = posCol e--      start :: String-      start = show sl ++ "," ++ show sc--      end :: String-      end | sl == el  = show ec-          | otherwise = show el ++ "," ++ show ec--instance Show a => Show (Interval' (Strict.Maybe a)) where-  show i@(Interval s _) = file ++ show (setIntervalFile () i)-    where-      file :: String-      file = case srcFile s of-               Strict.Nothing -> ""-               Strict.Just f  -> show f ++ ":"--instance Show a => Show (Range' (Strict.Maybe a)) where-  show r = case rangeToIntervalWithFile r of-    Nothing -> ""-    Just i  -> show i--instance Show a => Show (Range' (Maybe a)) where-  show = show . fmap Strict.toStrict-------------------------------------------------------------------------- -- Printing ------------------------------------------------------------------------ @@ -601,9 +575,7 @@                Strict.Just f  -> pretty f <> colon  instance Pretty a => Pretty (Range' (Strict.Maybe a)) where-  pretty r = case rangeToIntervalWithFile r of-    Nothing -> empty-    Just i  -> pretty i+  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))@@ -729,10 +701,10 @@ -- -- Precondition: The intervals must point to the same file. fuseIntervals :: Ord a => Interval' a -> Interval' a -> Interval' a-fuseIntervals x y = Interval { iStart = head ss, iEnd = last es }+fuseIntervals x y = Interval { iStart = s, iEnd = e }     where-    ss = sort [iStart x, iStart y]-    es = sort [iEnd   x, iEnd   y]+    s = headWithDefault __IMPOSSIBLE__ $ sort [iStart x, iStart y]+    e = lastWithDefault __IMPOSSIBLE__ $ sort [iEnd   x, iEnd   y]  -- | @fuseRanges r r'@ unions the ranges @r@ and @r'@. --

src/full/Agda/Syntax/Reflected.hs view

@@ -2,11 +2,16 @@  module Agda.Syntax.Reflected where +import Data.Text (Text)+ import Agda.Syntax.Common import Agda.Syntax.Literal import Agda.Syntax.Abstract.Name import Agda.Syntax.Internal (Dom) +import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+ type Args       = [Arg Term]  data Elim' a = Apply (Arg a) -- no record projections for now@@ -25,7 +30,7 @@           | Def QName Elims           | Meta MetaId Elims           | Lam Hiding (Abs Term)-          | ExtLam [Clause] Elims+          | ExtLam (List1 Clause) Elims           | Pi (Dom Type) (Abs Type)           | Sort Sort           | Lit Literal@@ -36,18 +41,30 @@  data Sort = SetS Term           | LitS Integer+          | PropS Term+          | PropLitS Integer+          | InfS Integer           | UnknownS   deriving (Show)  data Pattern = ConP QName [Arg Pattern]-             | DotP-             | VarP String+             | DotP Term+             | VarP Int              | LitP Literal-             | AbsurdP+             | AbsurdP Int              | ProjP QName   deriving (Show) -data Clause = Clause [Arg Pattern] Term | AbsurdClause [Arg Pattern]+data Clause+  = Clause+    { clauseTel  :: [(Text, Arg Type)]+    , clausePats :: [Arg Pattern]+    , clauseRHS  :: Term+    }+  | AbsurdClause+    { clauseTel  :: [(Text, Arg Type)]+    , clausePats :: [Arg Pattern]+    }   deriving (Show)  data Definition = FunDef Type [Clause]

src/full/Agda/Syntax/Scope/Base.hs view

@@ -1,30 +1,30 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs              #-}  {-| This module defines the notion of a scope and operations on scopes. -} module Agda.Syntax.Scope.Base where -import Prelude hiding ( null )+import Prelude hiding ( null, length ) -import Control.Arrow (first, second)+import Control.Arrow (first, second, (&&&))+import Control.DeepSeq import Control.Monad  import Data.Either (partitionEithers)+import Data.Foldable ( length, toList ) import Data.Function import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe-import qualified Data.Semigroup as Sgrp+import Data.Semigroup ( Semigroup(..) )  import Data.Data (Data) +import GHC.Generics (Generic)+ import Agda.Benchmarking  import Agda.Syntax.Position@@ -40,9 +40,12 @@ 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.Maybe (filterMaybe) import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Pretty hiding ((<>))+import qualified Agda.Utils.Pretty as P import Agda.Utils.Singleton import qualified Agda.Utils.Map as Map @@ -57,16 +60,21 @@       , scopeParents        :: [A.ModuleName]       , scopeNameSpaces     :: ScopeNameSpaces       , scopeImports        :: Map C.QName A.ModuleName-      , scopeDatatypeModule :: Maybe DataOrRecord+      , scopeDatatypeModule :: Maybe DataOrRecordModule       }-  deriving (Data, Eq, Show)+  deriving (Data, Eq, Show, Generic) +data DataOrRecordModule+  = IsDataModule+  | IsRecordModule+  deriving (Data, Show, Eq, Enum, Bounded, Generic)+ -- | See 'Agda.Syntax.Common.Access'. data NameSpaceId   = PrivateNS        -- ^ Things not exported by this module.   | PublicNS         -- ^ Things defined and exported by this module.   | ImportedNS       -- ^ Things from open public, exported by this module.-  deriving (Data, Eq, Bounded, Enum, Show)+  deriving (Data, Eq, Bounded, Enum, Show, Generic)  allNameSpaces :: [NameSpaceId] allNameSpaces = [minBound..maxBound]@@ -100,20 +108,37 @@ data ScopeInfo = ScopeInfo       { _scopeCurrent       :: A.ModuleName       , _scopeModules       :: Map A.ModuleName Scope-      , _scopeVarsToBind    :: LocalVars+      , _scopeVarsToBind    :: LocalVars     -- ^ The variables that will be bound at the end+                                             --   of the current block of variables (i.e. clause).+                                             --   We collect them here instead of binding them+                                             --   immediately so we can avoid shadowing between+                                             --   variables in the same variable block.       , _scopeLocals        :: LocalVars-      , _scopePrecedence    :: PrecedenceStack+      , _scopePrecedence    :: !PrecedenceStack       , _scopeInverseName   :: NameMap       , _scopeInverseModule :: ModuleMap       , _scopeInScope       :: InScopeSet       , _scopeFixities      :: C.Fixities    -- ^ Maps concrete names C.Name to fixities       , _scopePolarities    :: C.Polarities  -- ^ Maps concrete names C.Name to polarities       }-  deriving (Data, Show)+  deriving (Data, Show, Generic) -type NameMap   = Map A.QName      (NonEmpty C.QName)+-- | 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.+  }+  deriving (Data, Show, Generic)++-- | Invariant: the 'KindOfName' components should be equal+--   whenever we have to 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 (NonEmpty C.QName)+-- type ModuleMap = Map A.ModuleName (List1 C.QName)  instance Eq ScopeInfo where   ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ =@@ -128,8 +153,16 @@   = LambdaBound  -- ^ @λ@ (currently also used for @Π@ and module parameters)   | PatternBound -- ^ @f ... =@   | LetBound     -- ^ @let ... in@-  deriving (Data, Show, Eq)+  | WithBound    -- ^ @| ... in q@+  deriving (Data, Show, Eq, Generic) +instance Pretty BindingSource where+  pretty = \case+    LambdaBound  -> "local"+    PatternBound -> "pattern"+    LetBound     -> "let-bound"+    WithBound    -> "with-bound"+ -- | A local variable can be shadowed by an import. --   In case of reference to a shadowed variable, we want to report --   a scope error.@@ -142,7 +175,7 @@      -- ^ If this list is not empty, the local variable is      --   shadowed by one or more imports.   }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  instance Eq LocalVar where   (==) = (==) `on` localVar@@ -153,7 +186,7 @@ -- | 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) = "." <> pretty x+  pretty (LocalVar x _ xs) = "." P.<> pretty x  -- | Shadow a local name by a non-empty list of imports. shadowLocal :: [AbstractName] -> LocalVar -> LocalVar@@ -277,7 +310,7 @@         -- ^ All abstract names targeted by a concrete name in scope.         --   Computed by 'recomputeInScopeSets'.       }-  deriving (Data, Eq, Show)+  deriving (Data, Eq, Show, Generic)  type ThingsInScope a = Map C.Name [a] type NamesInScope    = ThingsInScope AbstractName@@ -311,7 +344,7 @@  -- | Non-dependent tag for name or module. data NameOrModule = NameNotModule | ModuleNotName-  deriving (Data, Eq, Ord, Show, Enum, Bounded)+  deriving (Data, Eq, Ord, Show, Enum, Bounded, Generic)  ------------------------------------------------------------------------ -- * Decorated names@@ -325,7 +358,8 @@  -- Note: order does matter in this enumeration, see 'isDefName'. data KindOfName-  = ConName                  -- ^ Constructor name.+  = 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@@ -341,11 +375,42 @@   | PrimName                 -- ^ Name of a @primitive@.   | OtherDefName             -- ^ A @DefName@, but either other kind or don't know which kind.   -- End @DefName@.  Keep these together in sequence, for sake of @isDefName@!-  deriving (Eq, Ord, Show, Data, Enum, Bounded)+  deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic)  isDefName :: KindOfName -> Bool isDefName = (>= DataName) +isConName :: KindOfName -> Maybe Induction+isConName = \case+  ConName   -> Just Inductive+  CoConName -> Just CoInductive+  _ -> Nothing++conKindOfName :: Induction -> KindOfName+conKindOfName = \case+  Inductive   -> ConName+  CoInductive -> CoConName++-- | For ambiguous constructors, we might have both alternatives of 'Induction'.+--   In this case, we default to 'ConName'.+conKindOfName' :: Foldable t => t Induction -> KindOfName+conKindOfName' = conKindOfName . approxConInduction++-- | For ambiguous constructors, we might have both alternatives of 'Induction'.+--   In this case, we default to 'Inductive'.+approxConInduction :: Foldable t => t Induction -> Induction+approxConInduction = fromMaybe Inductive . exactConInduction++exactConInduction :: Foldable t => t Induction -> Maybe Induction+exactConInduction is = case toList is of+  [CoInductive] -> Just CoInductive+  [Inductive]   -> Just Inductive+  _ -> Nothing++-- | Only return @[Co]ConName@ if no ambiguity.+exactConName :: Foldable t => t Induction -> Maybe KindOfName+exactConName = fmap conKindOfName . exactConInduction+ -- | A set of 'KindOfName', for the sake of 'elemKindsOfNames'. data KindsOfNames   = AllKindsOfNames@@ -367,6 +432,13 @@ exceptKindsOfNames :: [KindOfName] -> KindsOfNames exceptKindsOfNames = ExceptKindsOfNames . Set.fromList +-- | Decorate something with 'KindOfName'++data WithKind a = WithKind+  { theKind     :: KindOfName+  , kindedThing :: a+  } deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable)+ -- | Where does a name come from? -- --   This information is solely for reporting to the user,@@ -378,7 +450,7 @@     -- ^ Imported from another module.   | Applied C.QName WhyInScope     -- ^ Imported by a module application.-  deriving (Data, Show)+  deriving (Data, Show, Generic)  -- | A decoration of 'Agda.Syntax.Abstract.Name.QName'. data AbstractName = AbsName@@ -392,11 +464,11 @@     -- ^ Additional information needed during scope checking. Currently used     --   for generalized data/record params.   }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  data NameMetadata = NoMetadata                   | GeneralizedVarsMetadata (Map A.QName A.Name)-  deriving (Data, Show)+  deriving (Data, Show, Generic)  -- | A decoration of abstract syntax module names. data AbstractModule = AbsModule@@ -405,7 +477,7 @@   , amodLineage :: WhyInScope     -- ^ Explanation where this name came from.   }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  instance Eq AbstractName where   (==) = (==) `on` anameName@@ -417,7 +489,7 @@   lensFixity = lensAnameName . lensFixity  -- | Van Laarhoven lens on 'anameName'.-lensAnameName :: Functor m => (A.QName -> m A.QName) -> AbstractName -> m AbstractName+lensAnameName :: Lens' A.QName AbstractName lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }  instance Eq AbstractModule where@@ -427,7 +499,7 @@   compare = compare `on` amodName  -- | Van Laarhoven lens on 'amodName'.-lensAmodName :: Functor m => (A.ModuleName -> m A.ModuleName) -> AbstractModule -> m AbstractModule+lensAmodName :: Lens' A.ModuleName AbstractModule lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }  @@ -439,30 +511,34 @@     }    | -- | Function, data/record type, postulate.-    DefinedName Access AbstractName -- ^ 'anameKind' can be 'DefName', 'MacroName', 'QuotableName'.+    DefinedName Access AbstractName A.Suffix -- ^ 'anameKind' can be 'DefName', 'MacroName', 'QuotableName'.    | -- | Record field name.  Needs to be distinguished to parse copatterns.-    FieldName (NonEmpty AbstractName)       -- ^ @('FldName' ==) . 'anameKind'@ for all names.+    FieldName (List1 AbstractName)       -- ^ @('FldName' ==) . 'anameKind'@ for all names.    | -- | Data or record constructor name.-    ConstructorName (NonEmpty AbstractName) -- ^ @('ConName' ==) . 'anameKind'@ for all names.+    ConstructorName (Set Induction) (List1 AbstractName) -- ^ @isJust . 'isConName' . 'anameKind'@ for all names.    | -- | Name of pattern synonym.-    PatternSynResName (NonEmpty AbstractName) -- ^ @('PatternSynName' ==) . 'anameKind'@ for all names.+    PatternSynResName (List1 AbstractName) -- ^ @('PatternSynName' ==) . 'anameKind'@ for all names.    | -- | Unbound name.     UnknownName-  deriving (Data, Show, Eq)+  deriving (Data, Show, Eq, Generic)  instance Pretty ResolvedName where   pretty = \case-    VarName x _         -> "variable"    <+> pretty x-    DefinedName a x     -> pretty a           <+> pretty x-    FieldName xs        -> "field"       <+> pretty xs-    ConstructorName xs  -> "constructor" <+> pretty xs-    PatternSynResName x -> "pattern"     <+> pretty x-    UnknownName         -> "<unknown name>"+    VarName x b          -> pretty b <+> "variable" <+> pretty x+    DefinedName a x s    -> pretty a      <+> (pretty x <> pretty s)+    FieldName xs         -> "field"       <+> pretty xs+    ConstructorName _ xs -> "constructor" <+> pretty xs+    PatternSynResName x  -> "pattern"     <+> pretty x+    UnknownName          -> "<unknown name>" +instance Pretty A.Suffix where+  pretty NoSuffix   = mempty+  pretty (Suffix i) = text (show i)+ -- * Operations on name and module maps.  mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a@@ -516,6 +592,16 @@ -- * General operations on scopes ------------------------------------------------------------------------ +instance Null Scope where+  empty = emptyScope+  null  = __IMPOSSIBLE__+    -- TODO: define when needed, careful about scopeNameSpaces!++instance Null ScopeInfo where+  empty = emptyScopeInfo+  null  = __IMPOSSIBLE__+    -- TODO: define when needed, careful about _scopeModules!+ -- | The empty scope. emptyScope :: Scope emptyScope = Scope@@ -757,20 +843,20 @@       -- with cost O(n log n) time, it makes sense to test for the identity.   | otherwise = (recomputeInScopeSets $ mergeScope sUse sRen, (nameClashes, moduleClashes))   where-    -- | Names kept via using/hiding.+    -- Names kept via using/hiding.     sUse :: Scope     sUse = useOrHide (usingOrHiding dir) s -    -- | Things kept (under a different name) via renaming.+    -- Things kept (under a different name) via renaming.     sRen :: Scope     sRen = rename impRenaming s -    -- | Which names are considered to be defined by a module?-    --   The ones actually defined there publicly ('publicNS')-    --   and the ones imported publicly ('ImportedNS')?+    -- Which names are considered to be defined by a module?+    -- The ones actually defined there publicly ('publicNS')+    -- and the ones imported publicly ('ImportedNS')?     exportedNSs = [PublicNS, ImportedNS] -    -- | Name clashes introduced by the @renaming@ clause.+    -- Name clashes introduced by the @renaming@ clause.     nameClashes :: Set C.Name     nameClashes = Map.keysSet rNames `Set.intersection` Map.keysSet uNames       -- NB: `intersection` returns a subset of the first argument.@@ -782,7 +868,7 @@       uNames = namesInScope exportedNSs sUse       rNames = namesInScope exportedNSs sRen -    -- | Module name clashes introduced by the @renaming@ clause.+    -- Module name clashes introduced by the @renaming@ clause.      -- Note: need to cut and paste because of 'InScope' dependent types trickery.     moduleClashes :: Set C.Name@@ -874,6 +960,12 @@     rName as = filterMaybe (not . null) $ filter (not . (`isInModule`        m) . anameName) as     rMod  as = filterMaybe (not . null) $ filter (not . (`isLtChildModuleOf` m) . amodName)  as +-- | Filter privates out of a `ScopeInfo`+withoutPrivates :: ScopeInfo -> ScopeInfo+withoutPrivates scope = over scopeModules (fmap $ restrictLocalPrivate m) scope+  where+  m = scope ^. scopeCurrent+ -- | Disallow using generalized variables from the scope disallowGeneralizedVars :: Scope -> Scope disallowGeneralizedVars = mapScope_ ((fmap . map) disallow) id id@@ -933,9 +1025,11 @@       | 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) $ concat $ Map.elems $ allNamesInScope s+        submods = map (lookP . amodName) $ concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s  -- | Compute a flattened scope. Only include unqualified names or names -- qualified by modules in the first argument.@@ -952,7 +1046,7 @@                [ 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 $ C.qnameParts c) ms+                     ms' = mapMaybe (List.stripPrefix $ List1.toList $ C.qnameParts c) ms                , not $ null ms' ]     qual c = Map.mapKeys (q c)       where@@ -961,7 +1055,7 @@      build :: [[C.Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map C.QName [AbstractName]     build ms getNames s = Map.unionsWith (++) $-        (Map.mapKeysMonotonic C.QName $ getNames s) :+        Map.mapKeysMonotonic C.QName (getNames s) :           [ Map.mapKeysMonotonic (\ y -> C.Qual x y) $               build ms' exportedNamesInScope $ moduleScope m           | (x, mods) <- Map.toList (getNames s)@@ -992,7 +1086,7 @@      build :: (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName     build getNames s = Set.unions $-        (Set.fromList $ map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) :+        Set.fromList (map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) :           [ Set.mapMonotonic (\ y -> C.Qual x y) $               build exportedNamesInScope $ moduleScope m           | (x, mods) <- Map.toList (getNames s)@@ -1023,19 +1117,19 @@     root    :: Scope     root    = mergeScopes $ current : map moduleScope (scopeParents current) -    -- | Find a concrete, possibly qualified name in scope @s@.+    -- Find a concrete, possibly qualified name in scope @s@.     findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)]     findName q0 s = case q0 of       C.QName x  -> lookupName x s       C.Qual x q -> do-        let -- | Get the modules named @x@ in scope @s@.+        let -- Get the modules named @x@ in scope @s@.             mods :: [A.ModuleName]             mods = amodName . fst <$> lookupName x s-            -- | Get the definitions named @x@ in scope @s@ and interpret them as modules.+            -- Get the definitions named @x@ in scope @s@ and interpret them as modules.             -- Andreas, 2013-05-01: Issue 836 debates this feature:             -- Qualified constructors are qualified by their datatype rather than a module-            defs :: [A.ModuleName]-            defs = mnameFromList . qnameToList . anameName . fst <$> lookupName x s+            defs :: [A.ModuleName] -- NB:: Defined but not used+            defs = qnameToMName . anameName . fst <$> lookupName x s         -- Andreas, 2013-05-01:  Issue 836 complains about the feature         -- that constructors can also be qualified by their datatype         -- and projections by their record type.  This feature is off@@ -1097,27 +1191,62 @@   billToPure [ Scoping, InverseScopeLookup ] $   Set.member q (scope ^. scopeInScope) --- | Find the concrete names that map (uniquely) to a given abstract name.---   Sort by length, shortest first.+isNameInScopeUnqualified :: A.QName -> ScopeInfo -> Bool+isNameInScopeUnqualified q scope =+  case inverseScopeLookupName' AmbiguousNothing q scope of+    C.QName{} : _ -> True -- NOTE: inverseScopeLookupName' puts unqualified names first+    _             -> False -inverseScopeLookup :: Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookup = inverseScopeLookup' AmbiguousConProjs+-- | Find the concrete names that map (uniquely) to a given abstract qualified name.+--   Sort by number of modules in the qualified name, unqualified names first.+inverseScopeLookupName :: A.QName -> ScopeInfo -> [C.QName]+inverseScopeLookupName = inverseScopeLookupName' AmbiguousConProjs -inverseScopeLookup' :: AllowAmbiguousNames -> Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookup' amb name scope = billToPure [ Scoping , InverseScopeLookup ] $-  case name of-    Left  m -> best $ filter unambiguousModule $ findModule m-    Right q -> best $ filter unambiguousName   $ findName q+inverseScopeLookupName' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> [C.QName]+inverseScopeLookupName' amb q scope =+  maybe [] (List1.toList . qnameConcrete) $ inverseScopeLookupName'' amb q scope++-- | 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-    findName   x = maybe [] NonEmpty.toList $ Map.lookup x (scope ^. scopeInverseName)-    findModule x = fromMaybe [] $ Map.lookup x (scope ^. scopeInverseModule)+    best :: [C.QName] -> [C.QName]+    best = List.sortOn $ length . C.qnameParts -    len :: C.QName -> Int-    len (C.QName _)  = 1-    len (C.Qual _ x) = 1 + len x+    unique :: forall a . [a] -> Bool+    unique []      = __IMPOSSIBLE__+    unique [_]     = True+    unique (_:_:_) = False +    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++-- | 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 ] $+  best $ filter unambiguousModule $ findModule m+  where+    findModule m = fromMaybe [] $ Map.lookup m (scope ^. scopeInverseModule)+     best :: [C.QName] -> [C.QName]-    best = List.sortBy (compare `on` len)+    best = List.sortOn $ length . C.qnameParts      unique :: forall a . [a] -> Bool     unique []      = __IMPOSSIBLE__@@ -1125,11 +1254,6 @@     unique (_:_:_) = False      unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule])-    unambiguousName   q = amb == AmbiguousAnything-        || unique xs-        || amb == AmbiguousConProjs-           && or [ all ((kind ==) . anameKind) xs | kind <- [ConName, FldName, PatternSynName] ]-      where xs = scopeLookup q scope  recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo recomputeInverseScopeMaps scope = billToPure [ Scoping , InverseScopeLookup ] $@@ -1153,7 +1277,7 @@     internalName (C.Qual m n) = intern m || internalName n       where       -- Recognize fresh names created Parser.y-      intern (C.Name _ _ [ C.Id ('.' : '#' : _) ]) = True+      intern (C.Name _ _ (C.Id ('.' : '#' : _) :| [])) = True       intern _ = False      findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName]@@ -1183,30 +1307,18 @@       return (q, singleton (m, x))      nameMap :: NameMap-    nameMap = Map.fromListWith (Sgrp.<>) $ do+    nameMap = Map.fromListWith (<>) $ do       (m, s)  <- scopes       (x, ms) <- Map.toList (allNamesInScope s)-      q       <- anameName <$> ms+      (q, k)  <- (anameName &&& anameKind) <$> ms+      let ret z = return (q, NameMapEntry k $ singleton z)       if m `elem` current-        then return (q, singleton (C.QName x))+        then ret $ C.QName x         else do           y <- findModule m           let z = C.qualify y x           guard $ not $ internalName z-          return (q, singleton z)---- | Find the concrete names that map (uniquely) to a given abstract qualified name.---   Sort by length, shortest first.-inverseScopeLookupName :: A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookupName x = inverseScopeLookup (Right x)--inverseScopeLookupName' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookupName' ambCon x = inverseScopeLookup' ambCon (Right x)---- | 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 x = inverseScopeLookup (Left x)+          ret z  ------------------------------------------------------------------------ -- * Update binding site@@ -1268,15 +1380,17 @@     pr (x, y) = pretty x <+> "-->" <+> pretty y  instance Pretty Scope where-  pretty (scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps }) =-    vcat $-      [ "scope" <+> pretty name ] ++ ind (-        concat [ blockOfLines (pretty nsid) $ prettyNameSpace ns-               | (nsid, ns) <- scopeNameSpaces scope ]-      ++ blockOfLines "imports"-           (case Map.keys imps of [] -> []; ks -> [ prettyList ks ])-      )-    where ind = map $ nest 2+  pretty scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps } =+    vcat $ concat+      [ [ "scope" <+> pretty name ]+      , scopeNameSpaces scope >>= \ (nsid, ns) -> do+          block (pretty nsid) $ prettyNameSpace ns+      , ifNull (Map.keys imps) [] {-else-} $ \ ks ->+          block "imports" [ prettyList ks ]+      ]+    where+    block :: Doc -> [Doc] -> [Doc]+    block hd = map (nest 2) . blockOfLines hd  -- | Add first string only if list is non-empty. blockOfLines :: Doc -> [Doc] -> [Doc]@@ -1284,16 +1398,17 @@ blockOfLines hd ss = hd : map (nest 2) ss  instance Pretty ScopeInfo where-  pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _) = vcat $-    [ "ScopeInfo"-    , "  current = " <> pretty this-    ] ++-    (if null toBind then [] else [ "  toBind  = " <> pretty locals ]) ++-    (if null locals then [] else [ "  locals  = " <> pretty locals ]) ++-    [ "  context = " <> pretty ctx-    , "  modules"-    ] ++-    map (nest 4) (List.filter (not . null) $ map pretty $ Map.elems mods)+  pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _) = vcat $ concat+    [ [ "ScopeInfo"+      , nest 2 $ "current =" <+> pretty this+      ]+    , [ nest 2 $ "toBind  =" <+> pretty locals | not (null toBind) ]+    , [ nest 2 $ "locals  =" <+> pretty locals | not (null locals) ]+    , [ nest 2 $ "context =" <+> pretty ctx+      , nest 2 $ "modules"+      ]+    , map (nest 4 . pretty) $ Map.elems mods+    ]  ------------------------------------------------------------------------ -- * Boring instances@@ -1307,3 +1422,19 @@  instance SetRange AbstractName where   setRange r x = x { anameName = setRange r $ anameName x }++instance NFData Scope+instance NFData DataOrRecordModule+instance NFData NameSpaceId+instance NFData ScopeInfo+instance NFData KindOfName+instance NFData NameMapEntry+instance NFData BindingSource+instance NFData LocalVar+instance NFData NameSpace+instance NFData NameOrModule+instance NFData WhyInScope+instance NFData AbstractName+instance NFData NameMetadata+instance NFData AbstractModule+instance NFData ResolvedName

src/full/Agda/Syntax/Scope/Monad.hs view

@@ -5,23 +5,22 @@  module Agda.Syntax.Scope.Monad where -import Prelude hiding (mapM, any, all, null)+import Prelude hiding (null)  import Control.Arrow ((***))-import Control.Monad hiding (mapM, forM)-import Control.Monad.Writer hiding (mapM, forM)-import Control.Monad.State hiding (mapM, forM)+import Control.Monad+import Control.Monad.Except+import Control.Monad.Writer hiding ((<>))+import Control.Monad.State  import Data.Either ( partitionEithers )+import Data.Foldable (all, traverse_) import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..), nonEmpty)-import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set-import Data.Foldable (all) import Data.Traversable hiding (for)  import Agda.Interaction.Options@@ -36,25 +35,33 @@ import Agda.Syntax.Abstract (ScopeCopyInfo(..)) import Agda.Syntax.Concrete as C import Agda.Syntax.Concrete.Fixity-import Agda.Syntax.Concrete.Definitions (DeclarationWarning(..)) -- TODO: move the relevant warnings out of there+import Agda.Syntax.Concrete.Definitions ( DeclarationWarning(..) ,DeclarationWarning'(..) )+  -- TODO: move the relevant warnings out of there import Agda.Syntax.Scope.Base as A  import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Builtin ( HasBuiltins , getBuiltinName' , builtinSet , builtinProp , builtinSetOmega, builtinSSetOmega ) import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.Trace import Agda.TypeChecking.Positivity.Occurrence (Occurrence)-import Agda.TypeChecking.Warnings ( warning )+import Agda.TypeChecking.Warnings ( warning, warning' )  import qualified Agda.Utils.AssocList as AssocList-import Agda.Utils.Except+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|), nonEmpty)+import Agda.Utils.List2 (List2(List2))+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Suffix as C  import Agda.Utils.Impossible @@ -73,11 +80,17 @@   locals <- getLocalVars   reportSLn "scope.top" v $ s ++ " " ++ prettyShow locals +scopeWarning' :: CallStack -> DeclarationWarning' -> ScopeM ()+scopeWarning' loc = warning' loc . NicifierIssue . DeclarationWarning loc++scopeWarning :: HasCallStack => DeclarationWarning' -> ScopeM ()+scopeWarning = withCallerCallStack scopeWarning'+ --------------------------------------------------------------------------- -- * General operations --------------------------------------------------------------------------- -isDatatypeModule :: ReadTCState m => A.ModuleName -> m (Maybe DataOrRecord)+isDatatypeModule :: ReadTCState m => A.ModuleName -> m (Maybe DataOrRecordModule) isDatatypeModule m = do    scopeDatatypeModule . Map.findWithDefault __IMPOSSIBLE__ m <$> useScope scopeModules @@ -116,8 +129,10 @@ getCurrentScope = getNamedScope =<< getCurrentModule  -- | Create a new module with an empty scope.+--   If the module is not new (e.g. duplicate @import@),+--   don't erase its contents. --   (@Just@ if it is a datatype or record module.)-createModule :: Maybe DataOrRecord -> A.ModuleName -> ScopeM ()+createModule :: Maybe DataOrRecordModule -> A.ModuleName -> ScopeM () createModule b m = do   reportSLn "scope.createModule" 10 $ "createModule " ++ prettyShow m   s <- getCurrentScope@@ -127,7 +142,10 @@                       , scopeDatatypeModule = b }   -- Andreas, 2015-07-02: internal error if module is not new.   -- Ulf, 2016-02-15: It's not new if multiple imports (#1770).-  modifyScopes $ Map.insertWith const m sm+  -- Andreas, 2020-05-18, issue #3933:+  -- 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  -- | Apply a function to the scope map. modifyScopes :: (Map A.ModuleName Scope -> Map A.ModuleName Scope) -> ScopeM ()@@ -209,17 +227,16 @@     -- Filter out the underscores.     let newNames = filter (not . isNoName) $ AssocList.keys diff     -- Associate each name to its occurrences.-    let nameOccs = Map.toList $ Map.fromListWith (++) $ map pairWithRange newNames+    let nameOccs1 :: [(C.Name, List1 Range)]+        nameOccs1 = Map.toList $ Map.fromListWith (<>) $ map pairWithRange newNames     -- Warn if we have two or more occurrences of the same name.-    unlessNull (filter (atLeastTwo . snd) nameOccs) $ \ conflicts -> do-      warning $ NicifierIssue $ ShadowingInTelescope conflicts+    let nameOccs2 :: [(C.Name, List2 Range)]+        nameOccs2 = mapMaybe (traverseF List2.fromList1Maybe) nameOccs1+    caseList nameOccs2 (return ()) $ \ c conflicts -> do+      scopeWarning $ ShadowingInTelescope $ c :| conflicts   where-    pairWithRange :: C.Name -> (C.Name, [Range])-    pairWithRange n = (n, [getRange n])--    atLeastTwo :: [a] -> Bool-    atLeastTwo (_ : _ : _) = True-    atLeastTwo _ = False+    pairWithRange :: C.Name -> (C.Name, List1 Range)+    pairWithRange n = (n, singleton $ getRange n)  getVarsToBind :: ScopeM LocalVars getVarsToBind = useScope scopeVarsToBind@@ -251,6 +268,7 @@   return $ A.Name     { nameId          = i     , nameConcrete    = x+    , nameCanonical   = x     , nameBindingSite = getRange x     , nameFixity      = fx     , nameIsRecordName = False@@ -273,11 +291,12 @@   freshAbstractQName fx x  -- | Create a concrete name that is not yet in scope.+-- | NOTE: See @chooseName@ in @Agda.Syntax.Translation.AbstractToConcrete@ for similar logic.+-- | NOTE: See @withName@ in @Agda.Syntax.Translation.ReflectedToAbstract@ for similar logic. freshConcreteName :: Range -> Int -> String -> ScopeM C.Name freshConcreteName r i s = do-  let cname = C.Name r C.NotInScope [Id $ stringToRawName $ s ++ show i]-  rn <- resolveName $ C.QName cname-  case rn of+  let cname = C.Name r C.NotInScope $ singleton $ Id $ stringToRawName $ s ++ show i+  resolveName (C.QName cname) >>= \case     UnknownName -> return cname     _           -> freshConcreteName r (i+1) s @@ -302,7 +321,7 @@   Right x' -> return x'  tryResolveName-  :: (ReadTCState m, MonadError (NonEmpty A.QName) m)+  :: (ReadTCState m, HasBuiltins m, MonadError (List1 A.QName) m)   => KindsOfNames       -- ^ Restrict search to these kinds of names.   -> Maybe (Set A.Name) -- ^ Unless 'Nothing', restrict search to match any of these names.   -> C.QName            -- ^ Name to be resolved@@ -320,23 +339,38 @@           throwError $ A.qualify_ y :| map anameName ys'     -- Case: we do not have a local variable x.     Nothing -> do-      -- Consider only names of one of the given kinds+      -- Consider only names that are in the given set of names and+      -- are of one of the given kinds       let filtKind = filter $ (`elemKindsOfNames` kinds) . anameKind . fst-      -- Consider only names in the given set of names-      caseMaybe (nonEmpty $ filtKind $ filterNames fst $ scopeLookup' x scope) (return UnknownName) $ \ case-        ds       | all ((ConName ==) . anameKind . fst) ds ->-          return $ ConstructorName $ fmap (upd . fst) ds+          possibleNames z = filtKind $ filterNames fst $ scopeLookup' z scope+      -- If the name has a suffix, also consider the possibility that+      -- the base name is in scope (e.g. the builtin sorts `Set` and `Prop`).+      canHaveSuffix <- canHaveSuffixTest+      let (xsuffix, xbase) = (C.lensQNameName . nameSuffix) (,Nothing) x+          possibleBaseNames = filter (canHaveSuffix . anameName . fst) $ possibleNames xbase+          suffixedNames = (,) <$> fromConcreteSuffix xsuffix <*> nonEmpty possibleBaseNames+      case (nonEmpty $ possibleNames x) of+        Just ds  | let ks = fmap (isConName . anameKind . fst) ds+                 , all isJust ks+                 , isNothing suffixedNames ->+          return $ ConstructorName (Set.fromList $ List1.catMaybes ks) $ fmap (upd . fst) ds -        ds       | all ((FldName ==) . anameKind . fst) ds ->+        Just ds  | all ((FldName ==) . anameKind . fst) ds , isNothing suffixedNames ->           return $ FieldName $ fmap (upd . fst) ds -        ds       | all ((PatternSynName ==) . anameKind . fst) ds ->+        Just ds  | all ((PatternSynName ==) . anameKind . fst) ds , isNothing suffixedNames ->           return $ PatternSynResName $ fmap (upd . fst) ds -        (d, a) :| [] ->-          return $ DefinedName a $ upd d+        Just ((d, a) :| []) | isNothing suffixedNames ->+          return $ DefinedName a (upd d) A.NoSuffix -        ds -> throwError $ fmap (anameName . fst) ds+        Just ds -> throwError $ fmap (anameName . fst) $ caseMaybe suffixedNames id ((<>) . snd) ds++        Nothing -> case suffixedNames of+          Nothing -> return UnknownName+          Just (suffix , (d, a) :| []) -> return $ DefinedName a (upd d) suffix+          Just (suffix , sds) -> throwError $ fmap (anameName . fst) sds+   where   -- @names@ intended semantics: a filter on names.   -- @Nothing@: don't filter out anything.@@ -350,7 +384,22 @@   updateConcreteName :: AbstractName -> C.Name -> AbstractName   updateConcreteName d@(AbsName { anameName = A.QName qm qn }) x =     d { anameName = A.QName (setRange (getRange x) qm) (qn { nameConcrete = x }) }+  fromConcreteSuffix = \case+    Nothing              -> Nothing+    Just C.Prime{}       -> Nothing+    Just (C.Index i)     -> Just $ A.Suffix $ toInteger i+    Just (C.Subscript i) -> Just $ A.Suffix $ toInteger i +-- | Test if a given abstract name can appear with a suffix. Currently+--   only true for the names of builtin sorts @Set@ and @Prop@.+canHaveSuffixTest :: HasBuiltins m => m (A.QName -> Bool)+canHaveSuffixTest = do+  builtinSet  <- getBuiltinName' builtinSet+  builtinProp <- getBuiltinName' builtinProp+  builtinSetOmega <- getBuiltinName' builtinSetOmega+  builtinSSetOmega <- getBuiltinName' builtinSSetOmega+  return $ \x -> Just x `elem` [builtinSet, builtinProp, builtinSetOmega, builtinSSetOmega]+ -- | Look up a module in the scope. resolveModule :: C.QName -> ScopeM AbstractModule resolveModule x = do@@ -374,10 +423,10 @@   throwMultiplePolarityPragmas xs     = case xs of     x : _ -> setCurrentRange (getRange x) $ typeError $ MultiplePolarityPragmas xs     []    -> __IMPOSSIBLE__-  warnUnknownNamesInFixityDecl        = warning   . NicifierIssue . UnknownNamesInFixityDecl-  warnUnknownNamesInPolarityPragmas   = warning   . NicifierIssue . UnknownNamesInPolarityPragmas-  warnUnknownFixityInMixfixDecl       = warning   . NicifierIssue . UnknownFixityInMixfixDecl-  warnPolarityPragmasButNotPostulates = warning   . NicifierIssue . PolarityPragmasButNotPostulates+  warnUnknownNamesInFixityDecl        = scopeWarning . UnknownNamesInFixityDecl+  warnUnknownNamesInPolarityPragmas   = scopeWarning . UnknownNamesInPolarityPragmas+  warnUnknownFixityInMixfixDecl       = scopeWarning . UnknownFixityInMixfixDecl+  warnPolarityPragmasButNotPostulates = scopeWarning . PolarityPragmasButNotPostulates  -- | Collect the fixity/syntax declarations and polarity pragmas from the list --   of declarations and store them in the scope.@@ -401,15 +450,15 @@   r <- resolveName' allKindsOfNames (Just ns) x   case r of     VarName y _         -> return $ namesToNotation x y-    DefinedName _ d     -> return $ notation d+    DefinedName _ d _   -> return $ notation d     FieldName ds        -> return $ oneNotation ds-    ConstructorName ds  -> return $ oneNotation ds+    ConstructorName _ ds-> return $ oneNotation ds     PatternSynResName n -> return $ oneNotation n     UnknownName         -> __IMPOSSIBLE__   where     notation = namesToNotation x . qnameName . anameName     oneNotation ds =-      case mergeNotations $ map notation $ NonEmpty.toList ds of+      case mergeNotations $ map notation $ List1.toList ds of         [n] -> n         _   -> __IMPOSSIBLE__ @@ -434,28 +483,34 @@ 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 = do+bindName' acc kind meta x y = whenJustM (bindName'' acc kind meta x y) typeError++-- | 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   r  <- resolveName (C.QName x)-  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 (mnameFromList []) z-    FieldName       ds  -> ambiguous FldName ds-    ConstructorName ds  -> ambiguous ConName ds-    PatternSynResName n -> ambiguous PatternSynName n-    UnknownName         -> success+  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+        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-  modifyCurrentScope $ addNameToScope ns x y'+  traverse_ (modifyCurrentScope . addNameToScope ns x) y'+  pure $ either Just (const Nothing) y'   where-    success = return $ AbsName y kind Defined meta-    clash   = typeError . ClashingDefinition (C.QName x)+    success = Right $ AbsName y kind Defined meta+    clash n = Left $ ClashingDefinition (C.QName x) n Nothing -    ambiguous k ds =-      if kind == k && all ((== k) . anameKind) ds-      then success else clash $ anameName (NonEmpty.head ds)+    ambiguous f ds =+      if f kind && all (f . anameKind) ds+      then success else clash $ anameName (List1.head ds)  -- | Rebind a name. Use with care! --   Ulf, 2014-06-29: Currently used to rebind the name defined by an@@ -490,7 +545,7 @@  data ScopeMemo = ScopeMemo   { memoNames   :: A.Ren A.QName-  , memoModules :: [(ModuleName, (ModuleName, Bool))]+  , 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.@@ -499,13 +554,13 @@ memoToScopeInfo :: ScopeMemo -> ScopeCopyInfo memoToScopeInfo (ScopeMemo names mods) =   ScopeCopyInfo { renNames   = names-                , renModules = [ (x, y) | (x, (y, _)) <- mods ] }+                , renModules = Map.map (pure . fst) mods }  -- | Create a new scope with the given name from an old scope. Renames --   public names in the old scope to match the new name and returns the --   renamings. copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)-copyScope oldc new0 s = (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$> runStateT (copy new0 s) (ScopeMemo [] [])+copyScope oldc new0 s = (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$> runStateT (copy new0 s) (ScopeMemo mempty mempty)   where     copy :: A.ModuleName -> Scope -> WSM Scope     copy new s = do@@ -538,12 +593,12 @@             _ -> lensAnameName f d          -- Adding to memo structure.-        addName x y     = modify $ \ i -> i { memoNames   = (x, y)        : memoNames   i }-        addMod  x y rec = modify $ \ i -> i { memoModules = (x, (y, rec)) : filter ((/= x) . fst) (memoModules i) }+        addName x y     = modify $ \ i -> i { memoNames   = Map.insertWith (<>) x (pure y) (memoNames i) }+        addMod  x y rec = modify $ \ i -> i { memoModules = Map.insert x (y, rec) (memoModules i) }          -- Querying the memo structure.-        findName x = lookup x <$> gets memoNames-        findMod  x = lookup x <$> gets memoModules+        findName x = gets (Map.lookup x . memoNames) -- NB:: Defined but not used+        findMod  x = gets (Map.lookup x . memoModules)          refresh :: A.Name -> WSM A.Name         refresh x = do@@ -570,9 +625,9 @@           -- would break the invariant that all functions in a module share the           -- module telescope. Instead we copy M1.M2.X to M.M2.X for a fresh           -- module M2 that gets the right telescope.-          m <- case x `isInModule` old of-                 True  -> return new'-                 False -> renMod' False (qnameModule x)+          m <- if x `isInModule` old+                 then return new'+                 else renMod' False (qnameModule x)                           -- Don't copy recursively here, we only know that the                           -- current name x should be copied.           -- Generate a fresh name for the target.@@ -614,7 +669,7 @@                --   return $ A.mnameFromList $ newL ++ suffix                -- Ulf, 2016-02-22: #1726                -- We still need to copy modules from 'open public'. Same as in renName.-               y <- refresh (last $ A.mnameToList x)+               y <- refresh $ lastWithDefault __IMPOSSIBLE__ $ A.mnameToList x                return $ A.mnameFromList $ newM ++ [y]             -- Andreas, Jesper, 2015-07-02: Issue 1597             -- Don't copy a module over itself, it will just be emptied of its contents.@@ -636,10 +691,11 @@ ---------------------------------------------------------------------------  -- | Warn about useless fixity declarations in @renaming@ directives.+--   Monadic for the sake of error reporting. checkNoFixityInRenamingModule :: [C.Renaming] -> ScopeM () checkNoFixityInRenamingModule ren = do   whenJust (nonEmpty $ mapMaybe rangeOfUselessInfix ren) $ \ rs -> do-    traceCall (SetRange $ getRange rs) $ do+    setCurrentRange rs $ do       warning $ FixityInRenamingModule rs   where   rangeOfUselessInfix :: C.Renaming -> Maybe Range@@ -647,26 +703,57 @@     Renaming ImportedModule{} _ mfx _ -> getRange <$> mfx     _ -> Nothing +-- Moved here carefully from Parser.y to preserve the archaeological artefact+-- dating from Oct 2005 (5ba14b647b9bd175733f9563e744176425c39126).+-- | Check that an import directive doesn't contain repeated names.+verifyImportDirective :: [C.ImportedName] -> C.HidingDirective -> C.RenamingDirective -> ScopeM ()+verifyImportDirective usn hdn ren =+    case filter ((>1) . length)+         $ List.group+         $ List.sort xs+    of+        []  -> return ()+        yss -> setCurrentRange yss $ genericError $+                "Repeated name" ++ s ++ " in import directive: " +++                concat (List.intersperse ", " $ map (prettyShow . head) yss)+            where+                s = case yss of+                        [_] -> ""+                        _   -> "s"+    where+        xs = usn ++ hdn ++ map renFrom ren+ -- | Apply an import directive and check that all the names mentioned actually --   exist.+--+--   Monadic for the sake of error reporting. applyImportDirectiveM   :: C.QName                           -- ^ Name of the scope, only for error reporting.   -> C.ImportDirective                 -- ^ Description of how scope is to be modified.   -> Scope                             -- ^ Input scope.   -> ScopeM (A.ImportDirective, Scope) -- ^ Scope-checked description, output scope.-applyImportDirectiveM m (ImportDirective rng usn' hdn' ren' public) scope = do+applyImportDirectiveM m (ImportDirective rng usn' hdn' ren' public) scope0 = do -    -- Modules names do not come with fixities, thus, we should complain if the-    -- user supplied fixity annotations to renaming-module clauses.+    -- Module names do not come with fixities, thus, we should complain if the+    -- user has supplied fixity annotations to @renaming module@ clauses.     checkNoFixityInRenamingModule ren' +    -- Andreas, 2020-06-06, issue #4707+    -- Duplicates in @using@ directive are dropped with a warning.+    usingList <- discardDuplicatesInUsing usn'++    -- 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'+     -- 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 usingList = fromUsing usn'     let (missingExports, namesA) = checkExist $ usingList ++ hdn' ++ map renFrom ren'     unless (null missingExports) $ setCurrentRange rng $ do       reportSLn "scope.import.apply" 20 $ "non existing names: " ++ prettyShow missingExports-      warning $ ModuleDoesntExport m missingExports+      warning $ ModuleDoesntExport m (Map.keys namesInScope) (Map.keys modulesInScope) missingExports      -- We can now define a cleaned-up version of the import directive.     let notMissing = not . (missingExports `hasElem`)  -- #3997, efficient lookup in missingExports@@ -685,13 +772,11 @@      -- Efficient test of whether a module import should be added to the import     -- of a definition (like a data or record definition).-    let extra x = and-          [ inNames       $ ImportedName   x-          , notMissing    $ ImportedModule x-          , not . inNames $ ImportedModule x-              -- The last test implies that @hiding (module M)@ prevents @module M@-              -- from entering the @using@ list in @addExtraModule@.-          ]+    let extra x = inNames (ImportedName   x)+               && notMissing (ImportedModule x)+               && (not . inNames $ ImportedModule x)+                  -- The last test implies that @hiding (module M)@ prevents @module M@+                  -- from entering the @using@ list in @addExtraModule@.      dir' <- sanityCheck (not . inNames) $ addExtraModules extra dir @@ -724,25 +809,38 @@     return (adir, scope') -- TODO Issue 1714: adir    where-    -- | Names in the @using@ directive-    fromUsing :: Using' a b -> [ImportedName' a b]-    fromUsing = \case-      Using  xs     -> xs-      UseEverything -> []+    -- Andreas, 2020-06-23, issue #4773, fixing regression in 2.5.1.+    -- Import directive may not mention private things.+    -- ```agda+    --   module M where private X = Set+    --   module N = M using (X)+    -- ```+    -- Further, modules (N) need not copy private things (X) from other+    -- modules (M) ever, since they cannot legally referred to+    -- (neither through qualification (N.X) nor open N).+    -- Thus, we can unconditionally remove private definitions+    -- before we apply the import directive.+    scope = restrictPrivate scope0 +    -- Return names in the @using@ directive, discarding duplicates.+    -- Monadic for the sake of throwing warnings.+    discardDuplicatesInUsing :: C.Using -> ScopeM [C.ImportedName]+    discardDuplicatesInUsing = \case+      UseEverything -> return []+      Using  xs     -> do+        let (ys, dups) = nubAndDuplicatesOn id xs+        List1.unlessNull dups $ warning . DuplicateUsing+        return ys+     -- If both @using@ and @hiding@ directive are present,     -- the hiding directive may only contain modules whose twins are mentioned.+    -- Monadic for the sake of error reporting.     sanityCheck notMentioned = \case       dir@(ImportDirective{ using = Using{}, hiding = ys }) -> do           let useless = \case                 ImportedName{}   -> True                 ImportedModule y -> notMentioned (ImportedName y)-          unlessNull (filter useless ys) $ \ uselessHiding -> do-            typeError $ GenericError $ unwords $-              [ "Hiding"-              , List.intercalate ", " $ map prettyShow uselessHiding-              , "has no effect"-              ]+          unlessNull (filter useless ys) $ warning . UselessHiding           -- We can empty @hiding@ now, since there is an explicit @using@ directive           -- and @hiding@ served its purpose to prevent modules to enter the @Using@ list.           return dir{ hiding = [] }@@ -763,13 +861,14 @@              [ r , Renaming (ImportedModule y) (ImportedModule z) Nothing rng ]           r -> [r] -    -- | Names and modules (abstract) in scope before the import.+    -- Names and modules (abstract) in scope before the import.     namesInScope   = (allNamesInScope scope :: ThingsInScope AbstractName)     modulesInScope = (allNamesInScope scope :: ThingsInScope AbstractModule)+    concreteNamesInScope = (Map.keys namesInScope ++ Map.keys modulesInScope :: [C.Name]) -    -- | AST versions of the concrete names passed as an argument.-    --   We get back a pair consisting of a list of missing exports first,-    --   and a list of successful imports second.+    -- AST versions of the concrete names passed as an argument.+    -- We get back a pair consisting of a list of missing exports first,+    -- and a list of successful imports second.     checkExist :: [ImportedName] -> ([ImportedName], [ImportedName' (C.Name, A.QName) (C.Name, A.ModuleName)])     checkExist xs = partitionEithers $ for xs $ \ name -> case name of       ImportedName x   -> ImportedName   . (x,) . setRange (getRange x) . anameName <$> resolve name x namesInScope@@ -858,8 +957,7 @@    -- Get the scope exported by module to be opened.   (adir, s') <- applyImportDirectiveM cm dir . inScopeBecause (Opened cm) .-                noGeneralizedVarsIfLetOpen kind .-                restrictPrivate =<< getNamedScope m+                noGeneralizedVarsIfLetOpen kind =<< getNamedScope m   let s  = setScopeAccess acc s'   let ns = scopeNameSpace acc s   modifyCurrentScope (`mergeScope` s)@@ -873,7 +971,7 @@   verboseS "scope.locals" 10 $ do     locals <- mapMaybe (\ (c,x) -> c <$ notShadowedLocal x) <$> getLocalVars     let newdefs = Map.keys $ nsNames ns-        shadowed = List.intersect locals newdefs+        shadowed = locals `List.intersect` newdefs     reportSLn "scope.locals" 10 $ "opening module shadows the following locals vars: " ++ prettyShow shadowed   -- Andreas, 2014-09-03, issue 1266: shadow local variables by imported defs.   modifyLocalVars $ AssocList.mapWithKey $ \ c x ->@@ -896,11 +994,11 @@              -- No ambiguity if concrete identifier is only mapped to             -- constructor names or only to projection names.-            defClash (_, qs) = not $ all (== ConName) ks || all (==FldName) ks+            defClash (_, qs) = not $ all (isJust . isConName) ks || all (==FldName) ks               where ks = map anameKind qs         -- We report the first clashing exported identifier.         unlessNull (filter (\ x -> defClash x) defClashes) $-          \ ((x, q:_) : _) -> typeError $ ClashingDefinition (C.QName x) $ anameName q+          \ ((x, q:_) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing          unlessNull modClashes $ \ ((_, ms) : _) -> do           caseMaybe (last2 ms) __IMPOSSIBLE__ $ \ (m0, m1) -> do

src/full/Agda/Syntax/Translation/AbstractToConcrete.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE CPP          #-}  -- {-# OPTIONS -fwarn-unused-binds #-} @@ -22,11 +21,13 @@     , preserveInteractionIds     , MonadAbsToCon, AbsToCon, Env     , noTakenNames+    , lookupQName     ) where  import Prelude hiding (null) -import Control.Arrow (first)+import Control.Arrow ((&&&), first)+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State @@ -39,7 +40,6 @@ import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Foldable as Fold-import Data.Traversable (traverse) import Data.Void import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty(..))@@ -49,11 +49,11 @@ import Agda.Syntax.Position import Agda.Syntax.Literal import Agda.Syntax.Info as A-import Agda.Syntax.Internal (MetaId(..)) import qualified Agda.Syntax.Internal as I import Agda.Syntax.Fixity import Agda.Syntax.Concrete as C import Agda.Syntax.Concrete.Pattern as C+import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views as A import Agda.Syntax.Abstract.Pattern as A@@ -69,15 +69,18 @@  import qualified Agda.Utils.AssocList as AssocList import Agda.Utils.Either-import Agda.Utils.Except import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List1 (List1, pattern (:|), (<|) )+import Agda.Utils.List2 (List2, pattern List2)+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Singleton import Agda.Utils.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Suffix  import Agda.Utils.Impossible @@ -180,7 +183,7 @@  -- | Treat illegally ambiguous names as UnknownNames. resolveName_ :: C.QName -> [A.Name] -> AbsToCon ResolvedName-resolveName_ q cands = either (const UnknownName) id <$> resolveName allKindsOfNames (Just $ Set.fromList cands) q+resolveName_ q cands = fromRight (const UnknownName) <$> resolveName allKindsOfNames (Just $ Set.fromList cands) q  -- The Monad -------------------------------------------------------------- @@ -210,14 +213,16 @@ -- TODO: Is there some way to automatically derive these boilerplate -- instances?  GeneralizedNewtypeDeriving fails us here. instance Functor AbsToCon where-  fmap f x = AbsToCon $ fmap f $ unAbsToCon x+  fmap f x = AbsToCon $ f <$> unAbsToCon x  instance Applicative AbsToCon where   pure x = AbsToCon $ pure x   f <*> m = AbsToCon $ unAbsToCon f <*> unAbsToCon m  instance Monad AbsToCon where-  m >>= f = AbsToCon $ unAbsToCon m >>= unAbsToCon . f+  -- ASR (2021-02-07). The eta-expansion @\m' -> unAbsToCon m'@ is+  -- required by GHC >= 9.0.1 (see Issue #4955).+  m >>= f = AbsToCon $ unAbsToCon m >>= (\m' -> unAbsToCon m'). f #if __GLASGOW_HASKELL__ < 808   fail = Fail.fail #endif@@ -238,17 +243,27 @@   locallyTCState l f m = AbsToCon $ locallyTCState l f $ unAbsToCon m  instance MonadStConcreteNames AbsToCon where-  runStConcreteNames m = AbsToCon $ runStConcreteNames $ StateT $ unAbsToCon . runStateT m+  -- ASR (2021-02-07). The eta-expansion @\m' -> unAbsToCon m'@ is+  -- required by GHC >= 9.0.1 (see Issue #4955).+  runStConcreteNames m =+    AbsToCon $ runStConcreteNames $ StateT $ (\m' -> unAbsToCon m') . runStateT m +instance HasBuiltins AbsToCon where+  getBuiltinThing x = AbsToCon $ getBuiltinThing x+ instance HasOptions AbsToCon where   pragmaOptions = AbsToCon pragmaOptions   commandLineOptions = AbsToCon commandLineOptions  instance MonadDebug AbsToCon where-  displayDebugMessage k n s = AbsToCon $ displayDebugMessage k n s-  formatDebugMessage k n s = AbsToCon $ formatDebugMessage k n s-  verboseBracket k n s m = AbsToCon $ verboseBracket k n s $ unAbsToCon m+  formatDebugMessage k n s      = AbsToCon $ formatDebugMessage k n s+  traceDebugMessage  k n s cont = AbsToCon $ traceDebugMessage  k n s $ unAbsToCon cont  -- can't eta-reduce!+  verboseBracket     k n s cont = AbsToCon $ verboseBracket     k n s $ unAbsToCon cont  -- because of GHC-9.0 +  getVerbosity     = defaultGetVerbosity+  isDebugPrinting  = defaultIsDebugPrinting+  nowDebugPrinting = defaultNowDebugPrinting+ runAbsToCon :: MonadAbsToCon m => AbsToCon c -> m c runAbsToCon m = do   scope <- getScope@@ -261,20 +276,20 @@     reportSLn "toConcrete" 50 $ "leaving AbsToCon"     return x -abstractToConcreteScope :: (ToConcrete a c, MonadAbsToCon m)-                        => ScopeInfo -> a -> m c+abstractToConcreteScope :: (ToConcrete a, MonadAbsToCon m)+                        => ScopeInfo -> a -> m (ConOfAbs a) abstractToConcreteScope scope a = runReaderT (unAbsToCon $ toConcrete a) =<< makeEnv scope -abstractToConcreteCtx :: (ToConcrete a c, MonadAbsToCon m)-                      => Precedence -> a -> m c+abstractToConcreteCtx :: (ToConcrete a, MonadAbsToCon m)+                      => Precedence -> a -> m (ConOfAbs a) abstractToConcreteCtx ctx x = runAbsToCon $ withPrecedence ctx (toConcrete x) -abstractToConcrete_ :: (ToConcrete a c, MonadAbsToCon m)-                    => a -> m c+abstractToConcrete_ :: (ToConcrete a, MonadAbsToCon m)+                    => a -> m (ConOfAbs a) abstractToConcrete_ = runAbsToCon . toConcrete -abstractToConcreteHiding :: (LensHiding i, ToConcrete a c, MonadAbsToCon m)-                         => i -> a -> m c+abstractToConcreteHiding :: (LensHiding i, ToConcrete a, MonadAbsToCon m)+                         => i -> a -> m (ConOfAbs a) abstractToConcreteHiding i = runAbsToCon . toConcreteHiding i  -- Dealing with names -----------------------------------------------------@@ -292,7 +307,7 @@ lookupQName ambCon x | Just s <- getGeneralizedFieldName x =   return (C.QName $ C.Name noRange C.InScope $ C.stringNameParts s) lookupQName ambCon x = do-  ys <- inverseScopeLookupName' ambCon x <$> asks currentScope+  ys <- asks (inverseScopeLookupName' ambCon x . currentScope)   reportSLn "scope.inverse" 100 $     "inverse looking up abstract name " ++ prettyShow x ++ " yields " ++ prettyShow ys   loop ys@@ -309,7 +324,7 @@       qy@C.QName{} -> C.QName <$> chooseName (qnameName x)  lookupModule :: A.ModuleName -> AbsToCon C.QName-lookupModule (A.MName []) = return $ C.QName $ C.Name noRange InScope [Id "-1"]+lookupModule (A.MName []) = return $ C.QName $ C.simpleName "-1"   -- Andreas, 2016-10-10 it can happen that we have an empty module name   -- for instance when we query the current module inside the   -- frontmatter or module telescope of the top level module.@@ -326,7 +341,7 @@ --   name in the current scope? lookupNameInScope :: C.Name -> AbsToCon (Maybe A.Name) lookupNameInScope y =-  fmap localVar . lookup y <$> asks ((^. scopeLocals) . currentScope)+  asks ((fmap localVar . lookup y) . ((^. scopeLocals) . currentScope))  -- | Have we already committed to a specific concrete name for this --   abstract name? If yes, return the concrete name(s).@@ -365,13 +380,15 @@     -- Is 'y' a good concrete name for abstract name 'x'?     isGoodName :: A.Name -> C.Name -> AbsToCon Bool     isGoodName x y = do-      zs <- Set.toList <$> asks takenVarNames+      zs <- asks (Set.toList . takenVarNames)       allM zs $ \z -> if x == z then return True else do         czs <- hasConcreteNames z-        return $ all (/= y) czs+        return $ notElem y czs   -- | Choose a new unshadowed name for the given abstract name+-- | NOTE: See @withName@ in @Agda.Syntax.Translation.ReflectedToAbstract@ for similar logic.+-- | NOTE: See @freshConcreteName@ in @Agda.Syntax.Scope.Monad@ also for similar logic. chooseName :: A.Name -> AbsToCon C.Name chooseName x = lookupNameInScope (nameConcrete x) >>= \case   -- If the name is currently in scope, we do not rename it@@ -383,8 +400,12 @@   _ -> do     taken   <- takenNames     toAvoid <- shadowingNames x+    glyphMode <- optUseUnicode <$> pragmaOptions+    let freshNameMode = case glyphMode of+          UnicodeOk -> A.UnicodeSubscript+          AsciiOnly -> A.AsciiCounter     let shouldAvoid = (`Set.member` (taken `Set.union` toAvoid)) . C.nameToRawName-        y = firstNonTakenName shouldAvoid $ nameConcrete x+        y = firstNonTakenName freshNameMode shouldAvoid $ nameConcrete x     reportSLn "toConcrete.bindName" 80 $ render $ vcat       [ "picking concrete name for:" <+> text (C.nameToRawName $ nameConcrete x)       , "names already taken:      " <+> prettyList_ (Set.toList taken)@@ -407,13 +428,13 @@ bindName :: A.Name -> (C.Name -> AbsToCon a) -> AbsToCon a bindName x ret = do   y <- toConcreteName x-  reportSLn "toConcrete.bindName" 30 $ "adding " ++ (C.nameToRawName $ nameConcrete x) ++ " to the scope under concrete name " ++ C.nameToRawName y+  reportSLn "toConcrete.bindName" 30 $ "adding " ++ C.nameToRawName (nameConcrete x) ++ " to the scope under concrete name " ++ C.nameToRawName y   local (addBinding y x) $ ret y  -- | Like 'bindName', but do not care whether name is already taken. bindName' :: A.Name -> AbsToCon a -> AbsToCon a bindName' x ret = do-  reportSLn "toConcrete.bindName" 30 $ "adding " ++ (C.nameToRawName $ nameConcrete x) ++ " to the scope with forced name"+  reportSLn "toConcrete.bindName" 30 $ "adding " ++ C.nameToRawName (nameConcrete x) ++ " to the scope with forced name"   pickConcreteName x y   applyUnless (isNoName y) (local $ addBinding y x) ret   where y = nameConcrete x@@ -468,16 +489,12 @@ -- | If a name is defined with a fixity that differs from the default, we have --   to generate a fixity declaration for that name. withInfixDecl :: DefInfo -> C.Name -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]-withInfixDecl i x m = do-  ds <- m-  return $ fixDecl ++ synDecl ++ ds- where fixDecl = [C.Infix (theFixity $ defFixity i) [x] | theFixity (defFixity i) /= noFixity]-       synDecl = [C.Syntax x (theNotation (defFixity i))]--{- UNUSED-withInfixDecls :: [(DefInfo, C.Name)] -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]-withInfixDecls = foldr (.) id . map (uncurry withInfixDecl)--}+withInfixDecl i x m = ((fixDecl ++ synDecl) ++) <$> m+  where+  fixDecl = [ C.Infix (theFixity $ defFixity i) $ singleton x+            | theFixity (defFixity i) /= noFixity+            ]+  synDecl = [ C.Syntax x $ theNotation $ defFixity i ]  -- Dealing with private definitions --------------------------------------- @@ -501,9 +518,10 @@  -- The To Concrete Class -------------------------------------------------- -class ToConcrete a c | a -> c where-    toConcrete :: a -> AbsToCon c-    bindToConcrete :: a -> (c -> AbsToCon b) -> AbsToCon b+class ToConcrete a where+    type ConOfAbs a+    toConcrete :: a -> AbsToCon (ConOfAbs a)+    bindToConcrete :: a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b      -- Christian Sattler, 2017-08-05:     -- These default implementations are not valid semantically (at least@@ -512,23 +530,23 @@     bindToConcrete x ret = ret =<< toConcrete x  -- | Translate something in a context of the given precedence.-toConcreteCtx :: ToConcrete a c => Precedence -> a -> AbsToCon c+toConcreteCtx :: ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a) toConcreteCtx p x = withPrecedence p $ toConcrete x  -- | Translate something in a context of the given precedence.-bindToConcreteCtx :: ToConcrete a c => Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b+bindToConcreteCtx :: ToConcrete a => Precedence -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b bindToConcreteCtx p x ret = withPrecedence p $ bindToConcrete x ret  -- | Translate something in the top context.-toConcreteTop :: ToConcrete a c => a -> AbsToCon c+toConcreteTop :: ToConcrete a => a -> AbsToCon (ConOfAbs a) toConcreteTop = toConcreteCtx TopCtx  -- | Translate something in the top context.-bindToConcreteTop :: ToConcrete a c => a -> (c -> AbsToCon b) -> AbsToCon b+bindToConcreteTop :: ToConcrete a => a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b bindToConcreteTop = bindToConcreteCtx TopCtx  -- | Translate something in a context indicated by 'Hiding' info.-toConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> AbsToCon c+toConcreteHiding :: (LensHiding h, ToConcrete a) => h -> a -> AbsToCon (ConOfAbs a) toConcreteHiding h =   case getHiding h of     NotHidden  -> toConcrete@@ -536,7 +554,7 @@     Instance{} -> toConcreteTop  -- | Translate something in a context indicated by 'Hiding' info.-bindToConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> (c -> AbsToCon b) -> AbsToCon b+bindToConcreteHiding :: (LensHiding h, ToConcrete a) => h -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b bindToConcreteHiding h =   case getHiding h of     NotHidden  -> bindToConcrete@@ -545,27 +563,39 @@  -- General instances ------------------------------------------------------ -instance ToConcrete () () where+instance ToConcrete () where+  type ConOfAbs () = ()   toConcrete = pure -instance ToConcrete Bool Bool where+instance ToConcrete Bool where+  type ConOfAbs Bool = Bool   toConcrete = pure -instance ToConcrete a c => ToConcrete [a] [c] where+instance ToConcrete a => ToConcrete [a] where+    type ConOfAbs [a] = [ConOfAbs a]+     toConcrete     = mapM toConcrete+    bindToConcrete []     ret = ret []+    bindToConcrete (a:as) ret = bindToConcrete (a:|as) $ \ (c:|cs) -> ret (c:cs)++instance ToConcrete a => ToConcrete (List1 a) where+    type ConOfAbs (List1 a) = List1 (ConOfAbs a)++    toConcrete     = mapM toConcrete     -- Andreas, 2017-04-11, Issue #2543     -- The naive `thread'ing does not work as we have to undo     -- changes to the Precedence.     -- bindToConcrete = thread bindToConcrete-    bindToConcrete []     ret = ret []-    bindToConcrete (a:as) ret = do+    bindToConcrete (a :| as) ret = do       p <- currentPrecedence  -- save precedence       bindToConcrete a $ \ c ->         withPrecedence' p $ -- reset precedence           bindToConcrete as $ \ cs ->-            ret (c : cs)+            ret (c :| cs) -instance (ToConcrete a1 c1, ToConcrete a2 c2) => ToConcrete (Either a1 a2) (Either c1 c2) where+instance (ToConcrete a1, ToConcrete a2) => ToConcrete (Either a1 a2) where+    type ConOfAbs (Either a1 a2) = Either (ConOfAbs a1) (ConOfAbs a2)+     toConcrete = traverseEither toConcrete toConcrete     bindToConcrete (Left x) ret =         bindToConcrete x $ \x ->@@ -574,15 +604,18 @@         bindToConcrete y $ \y ->         ret (Right y) -instance (ToConcrete a1 c1, ToConcrete a2 c2) => ToConcrete (a1,a2) (c1,c2) where+instance (ToConcrete a1, ToConcrete a2) => ToConcrete (a1, a2) where+    type ConOfAbs (a1, a2) = (ConOfAbs a1, ConOfAbs a2)+     toConcrete (x,y) = liftM2 (,) (toConcrete x) (toConcrete y)     bindToConcrete (x,y) ret =         bindToConcrete x $ \x ->         bindToConcrete y $ \y ->         ret (x,y) -instance (ToConcrete a1 c1, ToConcrete a2 c2, ToConcrete a3 c3) =>-         ToConcrete (a1,a2,a3) (c1,c2,c3) where+instance (ToConcrete a1, ToConcrete a2, ToConcrete a3) => ToConcrete (a1,a2,a3) where+    type ConOfAbs (a1, a2, a3) = (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)+     toConcrete (x,y,z) = reorder <$> toConcrete (x,(y,z))         where             reorder (x,(y,z)) = (x,y,z)@@ -591,55 +624,86 @@         where             reorder (x,(y,z)) = (x,y,z) -instance ToConcrete a c => ToConcrete (Arg a) (Arg c) where+instance ToConcrete a => ToConcrete (Arg a) where+    type ConOfAbs (Arg a) = Arg (ConOfAbs a)+     toConcrete (Arg i a) = Arg i <$> toConcreteHiding i a      bindToConcrete (Arg info x) ret =       bindToConcreteHiding info x $ ret . Arg info -instance ToConcrete a c => ToConcrete (WithHiding a) (WithHiding c) where+instance ToConcrete a => ToConcrete (WithHiding a) where+  type ConOfAbs (WithHiding a) = WithHiding (ConOfAbs a)+   toConcrete     (WithHiding h a) = WithHiding h <$> toConcreteHiding h a   bindToConcrete (WithHiding h a) ret = bindToConcreteHiding h a $ \ a ->     ret $ WithHiding h a -instance ToConcrete a c => ToConcrete (Named name a) (Named name c) where+instance ToConcrete a => ToConcrete (Named name a)  where+    type ConOfAbs (Named name a) = Named name (ConOfAbs a)+     toConcrete (Named n x) = Named n <$> toConcrete x     bindToConcrete (Named n x) ret = bindToConcrete x $ ret . Named n  -- Names ------------------------------------------------------------------ -instance ToConcrete A.Name C.Name where+instance ToConcrete A.Name where+  type ConOfAbs A.Name = C.Name+   toConcrete       = toConcreteName   bindToConcrete x = bindName x -instance ToConcrete BindName C.BoundName where+instance ToConcrete BindName where+  type ConOfAbs BindName = C.BoundName+   toConcrete       = fmap C.mkBoundName_ . toConcreteName . unBind   bindToConcrete x = bindName (unBind x) . (. C.mkBoundName_) -instance ToConcrete A.QName C.QName where+instance ToConcrete A.QName where+  type ConOfAbs A.QName = C.QName+   toConcrete = lookupQName AmbiguousConProjs -instance ToConcrete A.ModuleName C.QName where+instance ToConcrete A.ModuleName where+  type ConOfAbs A.ModuleName = C.QName   toConcrete = lookupModule -instance ToConcrete AbstractName C.QName where+instance ToConcrete AbstractName where+  type ConOfAbs AbstractName = C.QName   toConcrete = toConcrete . anameName  -- | Assumes name is not 'UnknownName'.-instance ToConcrete ResolvedName C.QName where+instance ToConcrete ResolvedName where+  type ConOfAbs ResolvedName = C.QName+   toConcrete = \case     VarName x _          -> C.QName <$> toConcrete x-    DefinedName _ x      -> toConcrete x+    DefinedName _ x s    -> addSuffixConcrete s $ toConcrete x     FieldName xs         -> toConcrete (NonEmpty.head xs)-    ConstructorName xs   -> toConcrete (NonEmpty.head xs)+    ConstructorName _ xs -> toConcrete (NonEmpty.head xs)     PatternSynResName xs -> toConcrete (NonEmpty.head xs)     UnknownName          -> __IMPOSSIBLE__ +addSuffixConcrete :: HasOptions m => A.Suffix -> m C.QName -> m C.QName+addSuffixConcrete A.NoSuffix x = x+addSuffixConcrete (A.Suffix i) x = do+  glyphMode <- optUseUnicode <$> pragmaOptions+  addSuffixConcrete' glyphMode i <$> x++addSuffixConcrete' :: UnicodeOrAscii -> Integer -> C.QName -> C.QName+addSuffixConcrete' glyphMode i = set (C.lensQNameName . nameSuffix) suffix+  where+    suffix = Just $ case glyphMode of+      UnicodeOk -> Subscript $ fromInteger i+      AsciiOnly -> Index $ fromInteger i+ -- Expression instance ---------------------------------------------------- -instance ToConcrete A.Expr C.Expr where+instance ToConcrete A.Expr where+    type ConOfAbs A.Expr = C.Expr+     toConcrete (Var x)             = Ident . C.QName <$> toConcrete x-    toConcrete (Def x)             = Ident <$> toConcrete x+    toConcrete (Def' x suffix)     = Ident <$> addSuffixConcrete suffix (toConcrete x)     toConcrete (Proj ProjPrefix p) = Ident <$> toConcrete (headAmbQ p)     toConcrete (Proj _          p) = C.Dot noRange . Ident <$> toConcrete (headAmbQ p)     toConcrete (A.Macro x)         = Ident <$> toConcrete x@@ -647,11 +711,12 @@         -- 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)-    toConcrete e@(A.Lit (LitQName r x)) = tryToRecoverPatternSyn e $ do+    toConcrete e@(A.Lit i (LitQName x)) = tryToRecoverPatternSyn e $ do       x <- lookupQName AmbiguousNothing x+      let r = getRange i       bracket appBrackets $ return $         C.App r (C.Quote r) (defaultNamedArg $ C.Ident x)-    toConcrete e@(A.Lit l) = tryToRecoverPatternSyn e $ return $ C.Lit l+    toConcrete e@(A.Lit i l) = tryToRecoverPatternSyn e $ return $ C.Lit (getRange i) l      -- Andreas, 2014-05-17  We print question marks with their     -- interaction id, in case @metaNumber /= Nothing@@@ -680,9 +745,9 @@         (Just (HdDef q), l@A.Lit{})           | any (is q) [builtinFromNat, builtinFromString], visible e2,             getOrigin i == Inserted -> toConcrete l-        (Just (HdDef q), A.Lit (LitNat r n))+        (Just (HdDef q), A.Lit r (LitNat n))           | q `is` builtinFromNeg, visible e2,-            getOrigin i == Inserted -> toConcrete (A.Lit (LitNat r (-n)))+            getOrigin i == Inserted -> toConcrete (A.Lit r (LitNat (-n)))         _ ->           tryToRecoverPatternSyn e           $ tryToRecoverOpApp e@@ -701,15 +766,15 @@      toConcrete (A.AbsurdLam i h) =       bracket lamBrackets $ return $ C.AbsurdLam (getRange i) h-    toConcrete e@(A.Lam i _ _)      =-        tryToRecoverOpApp e   -- recover sections-        $ case lamView e of-            ([], e) -> toConcrete e-            (bs, e) -> bracket lamBrackets $-                bindToConcrete (map makeDomainFree bs) $ \ bs -> do-                  e  <- toConcreteTop e-                  return $ C.Lam (getRange i) bs e-        where+    toConcrete e@(A.Lam i _ _) =+      tryToRecoverOpApp e $   -- recover sections+        bindToConcrete (fmap makeDomainFree bs) $ \ bs' -> do+          List1.ifNull (catMaybes bs')+            {-then-} (toConcrete e')+            {-else-} $ \ bs -> bracket lamBrackets $+              C.Lam (getRange i) bs <$> toConcreteTop e'+      where+          (bs, e') = lamView e           -- #3238 GA: We drop the hidden lambda abstractions which have           -- been inserted by the machine rather than the user. This means           -- that the result of lamView may actually be an empty list of@@ -724,14 +789,14 @@             (bs@(A.DomainFull _ : _), e) -> (b:bs, e)             _                            -> ([b], e)           lamView (A.Lam _ (A.DomainFull (A.TBind r t xs ty)) e) =-            case filter (not . isInsertedHidden) xs of-              []  -> lamView e-              xs' -> let b = A.DomainFull (A.TBind r t xs' ty) in+            case List1.filter (not . isInsertedHidden) xs of+              []    -> lamView e+              x:xs' -> let b = A.DomainFull (A.TBind r t (x :| xs') ty) in                 case lamView e of                   (bs@(A.DomainFull _ : _), e) -> (b:bs, e)                   _                            -> ([b], e)           lamView e = ([], e)-    toConcrete (A.ExtendedLam i di qname cs) =+    toConcrete (A.ExtendedLam i di erased qname cs) =         bracket lamBrackets $ do           decls <- concat <$> toConcrete cs           let namedPat np = case getHiding np of@@ -740,37 +805,38 @@                  Instance{} -> C.InstanceP noRange (unArg np)               -- we know all lhs are of the form `.extlam p1 p2 ... pn`,               -- with the name .extlam leftmost. It is our mission to remove it.-          let removeApp (C.RawAppP r (_:es)) = return $ C.RawAppP r es-              removeApp (C.AppP (C.IdentP _) np) = return $ namedPat np-              removeApp (C.AppP p np) = do-                p <- removeApp p-                return $ C.AppP p np-+          let removeApp :: C.Pattern -> AbsToCon [C.Pattern]+              removeApp (C.RawAppP _ (List2 _ p ps)) = return $ p:ps+              removeApp (C.AppP (C.IdentP _) np) = return [namedPat np]+              removeApp (C.AppP p np)            = removeApp p <&> (++ [namedPat np])               -- Andreas, 2018-06-18, issue #3136               -- Empty pattern list also allowed in extended lambda,               -- thus, we might face the unapplied .extendedlambda identifier.-              removeApp x@C.IdentP{} = return $ C.RawAppP (getRange x) []+              removeApp x@C.IdentP{} = return []                removeApp p = do                 reportSLn "extendedlambda" 50 $ "abstractToConcrete removeApp p = " ++ show p-                return p -- __IMPOSSIBLE__ -- Andreas, this is actually not impossible, my strictification exposed this sleeping bug-          let decl2clause (C.FunClause lhs rhs wh ca) = do-                let p = lhsOriginalPattern lhs+                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                 reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda pattern p = " ++ show p-                p' <- removeApp p-                reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda pattern p' = " ++ show p'-                return $ LamClause lhs{ lhsOriginalPattern = p' } rhs wh ca+                ps <- removeApp p+                reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps+                return $ LamClause ps rhs ca               decl2clause _ = __IMPOSSIBLE__-          C.ExtendedLam (getRange i) <$> mapM decl2clause decls-    toConcrete (A.Pi _ [] e) = toConcrete e-    toConcrete t@(A.Pi i _ _)  = case piTel t of-      (tel, e) ->-        bracket piBrackets-        $ bindToConcrete tel $ \ tel' -> do-             e' <- toConcreteTop e-             return $ C.Pi tel' e'+          C.ExtendedLam (getRange i) erased . List1.fromList <$>+            mapM decl2clause decls+            -- TODO List1: can we demonstrate non-emptiness?++    toConcrete (A.Pi _ tel1 e0) = do+      let (tel, e) = piTel1 tel1 e0+      bracket piBrackets $+         bindToConcrete tel $ \ tel' ->+           C.makePi (List1.catMaybes tel') <$> toConcreteTop e       where-        piTel (A.Pi _ tel e) = first (tel ++) $ piTel e+        piTel1 tel e         = first (List1.append tel) $ piTel e+        piTel (A.Pi _ tel e) = first List1.toList $ piTel1 tel e         piTel e              = ([], e)      toConcrete (A.Generalized _ e) = C.Generalized <$> toConcrete e@@ -794,16 +860,11 @@                                           Instance{} -> InstanceArg (getRange e) (unnamed e)                                           NotHidden  -> e -    toConcrete (A.Set i 0)  = return $ C.Set (getRange i)-    toConcrete (A.Set i n)  = return $ C.SetN (getRange i) n-    toConcrete (A.Prop i 0) = return $ C.Prop (getRange i)-    toConcrete (A.Prop i n) = return $ C.PropN (getRange i) n-     toConcrete (A.Let i ds e) =         bracket lamBrackets         $ bindToConcrete ds $ \ds' -> do              e'  <- toConcreteTop e-             return $ C.Let (getRange i) (concat ds') (Just e')+             return $ C.mkLet (getRange i) (concat ds') e'      toConcrete (A.Rec i fs) =       bracket appBrackets $ do@@ -813,7 +874,7 @@       bracket appBrackets $ do         C.RecUpdate (getRange i) <$> toConcrete e <*> toConcreteTop fs -    toConcrete (A.ETel tel) = C.ETel <$> toConcrete tel+    toConcrete (A.ETel tel) = C.ETel . catMaybes <$> toConcrete tel      toConcrete (A.ScopedExpr _ e) = toConcrete e     toConcrete (A.Quote i) = return $ C.Quote (getRange i)@@ -833,7 +894,7 @@     toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete (headAmbQ n)  makeDomainFree :: A.LamBinding -> A.LamBinding-makeDomainFree b@(A.DomainFull (A.TBind _ tac [x] t)) =+makeDomainFree b@(A.DomainFull (A.TBind _ tac (x :| []) t)) =   case unScope t of     A.Underscore A.MetaInfo{metaNumber = Nothing} ->       A.DomainFree tac x@@ -845,7 +906,8 @@ -- to be implemented, each in terms of the corresponding one of ToConcrete a c. -- This mirrors the instance ToConcrete (Arg a) (Arg c). -- The default implementations of ToConcrete are not valid semantically.-instance ToConcrete a c => ToConcrete (FieldAssignment' a) (FieldAssignment' c) where+instance ToConcrete a => ToConcrete (FieldAssignment' a) where+    type ConOfAbs (FieldAssignment' a) = FieldAssignment' (ConOfAbs a)     toConcrete = traverse toConcrete      bindToConcrete (FieldAssignment name a) ret =@@ -867,45 +929,53 @@          $ C.nameToRawName $ nameConcrete          $ unBind $ A.binderName $ namedArg x -instance ToConcrete a b => ToConcrete (A.Binder' a) (C.Binder' b) where+instance ToConcrete a => ToConcrete (A.Binder' a) where+  type ConOfAbs (A.Binder' a) = C.Binder' (ConOfAbs a)+   bindToConcrete (A.Binder p a) ret =     bindToConcrete a $ \ a ->     bindToConcrete p $ \ p ->     ret $ C.Binder p a -instance ToConcrete A.LamBinding C.LamBinding where+instance ToConcrete A.LamBinding where+    type ConOfAbs A.LamBinding = Maybe C.LamBinding+     bindToConcrete (A.DomainFree t x) ret = do       t <- traverse toConcrete t       let setTac x = x { bnameTactic = t }       bindToConcrete (forceNameIfHidden x) $-        ret . C.DomainFree . updateNamedArg (fmap setTac)-    bindToConcrete (A.DomainFull b) ret = bindToConcrete b $ ret . C.DomainFull+        ret . Just . C.DomainFree . updateNamedArg (fmap setTac)+    bindToConcrete (A.DomainFull b) ret = bindToConcrete b $ ret . fmap C.DomainFull -instance ToConcrete A.TypedBinding C.TypedBinding where+instance ToConcrete A.TypedBinding where+    type ConOfAbs A.TypedBinding = Maybe C.TypedBinding+     bindToConcrete (A.TBind r t xs e) ret = do         t <- traverse toConcrete t-        bindToConcrete (map forceNameIfHidden xs) $ \ xs -> do+        bindToConcrete (fmap forceNameIfHidden xs) $ \ xs -> do           e <- toConcreteTop e           let setTac x = x { bnameTactic = t }-          ret $ C.TBind r (map (updateNamedArg (fmap setTac)) xs) e+          ret $ Just $ C.TBind r (fmap (updateNamedArg (fmap setTac)) xs) e     bindToConcrete (A.TLet r lbs) ret =         bindToConcrete lbs $ \ ds -> do-        ret $ C.TLet r $ concat ds+        ret $ C.mkTLet r $ concat ds -instance ToConcrete A.LetBinding [C.Declaration] where+instance ToConcrete A.LetBinding where+    type ConOfAbs A.LetBinding = [C.Declaration]+     bindToConcrete (A.LetBind i info x t e) ret =         bindToConcrete x $ \ x ->         do (t, (e, [], [], [])) <- toConcrete (t, A.RHS e Nothing)            ret $ addInstanceB (if isInstance info then Just noRange else Nothing) $                [ C.TypeSig info Nothing (C.boundName x) t-               , C.FunClause (C.LHS (C.IdentP $ C.QName $ C.boundName x) [] [] NoEllipsis)+               , C.FunClause (C.LHS (C.IdentP $ C.QName $ C.boundName x) [] [])                              e C.NoWhere False                ]     -- TODO: bind variables     bindToConcrete (LetPatBind i p e) ret = do         p <- toConcrete p         e <- toConcrete e-        ret [ C.FunClause (C.LHS p [] [] NoEllipsis) (C.RHS e) NoWhere False ]+        ret [ C.FunClause (C.LHS p [] []) (C.RHS e) NoWhere False ]     bindToConcrete (LetApply i x modapp _ _) ret = do       x' <- unqualify <$> toConcrete x       modapp <- toConcrete modapp@@ -924,21 +994,23 @@       -- Note that the range of the declaration site is dropped.       ret [] -instance ToConcrete A.WhereDeclarations WhereClause where-  bindToConcrete (A.WhereDecls _ []) ret = ret C.NoWhere-  bindToConcrete (A.WhereDecls (Just am) [A.Section _ _ _ ds]) ret = do+instance ToConcrete A.WhereDeclarations where+  type ConOfAbs A.WhereDeclarations = WhereClause++  bindToConcrete (A.WhereDecls _ Nothing) ret = ret C.NoWhere+  bindToConcrete (A.WhereDecls (Just am) (Just (A.Section _ _ _ ds))) ret = do     ds' <- declsToConcrete ds     cm  <- unqualify <$> lookupModule am     -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere     -- Should not really matter for printing...-    let wh' = (if isNoName cm then AnyWhere else SomeWhere cm PublicAccess) $ ds'+    let wh' = (if isNoName cm then AnyWhere noRange else SomeWhere noRange cm PublicAccess) $ ds'     local (openModule' am defaultImportDir id) $ ret wh'-  bindToConcrete (A.WhereDecls _ ds) ret =-    ret . AnyWhere =<< declsToConcrete ds+  bindToConcrete (A.WhereDecls _ (Just d)) ret =+    ret . AnyWhere noRange =<< toConcrete d  mergeSigAndDef :: [C.Declaration] -> [C.Declaration]-mergeSigAndDef (C.RecordSig _ x bs e : C.RecordDef r y ind eta c _ fs : ds)-  | x == y = C.Record r y ind eta c bs e fs : mergeSigAndDef ds+mergeSigAndDef (C.RecordSig _ x bs e : C.RecordDef r y dir _ fs : ds)+  | x == y = C.Record r y dir bs e fs : mergeSigAndDef ds mergeSigAndDef (C.DataSig _ x bs e : C.DataDef r y _ cs : ds)   | x == y = C.Data r y bs e cs : mergeSigAndDef ds mergeSigAndDef (d : ds) = d : mergeSigAndDef ds@@ -961,33 +1033,50 @@ declsToConcrete :: [A.Declaration] -> AbsToCon [C.Declaration] declsToConcrete ds = mergeSigAndDef . concat <$> toConcrete ds -instance ToConcrete A.RHS (C.RHS, [C.RewriteEqn], [WithHiding C.Expr], [C.Declaration]) where+instance ToConcrete A.RHS where+    type ConOfAbs A.RHS = (C.RHS, [C.RewriteEqn], [C.WithExpr], [C.Declaration])+     toConcrete (A.RHS e (Just c)) = return (C.RHS c, [], [], [])     toConcrete (A.RHS e Nothing) = do       e <- toConcrete e       return (C.RHS e, [], [], [])     toConcrete A.AbsurdRHS = return (C.AbsurdRHS, [], [], [])     toConcrete (A.WithRHS _ es cs) = do-      es <- toConcrete es+      es <- do es <- toConcrete es+               forM es $ \ (Named n e) -> do+                 n <- traverse toConcrete n+                 pure $ Named (C.boundName <$> n) e       cs <- noTakenNames $ concat <$> toConcrete cs       return (C.AbsurdRHS, [], es, cs)     toConcrete (A.RewriteRHS xeqs _spats rhs wh) = do-      wh <- declsToConcrete (A.whereDecls wh)+      wh <- maybe (return []) toConcrete $ A.whereDecls wh       (rhs, eqs', es, whs) <- toConcrete rhs       unless (null eqs') __IMPOSSIBLE__       eqs <- toConcrete xeqs       return (rhs, eqs, es, wh ++ whs) -instance (ToConcrete p q, ToConcrete a b) =>-         ToConcrete (RewriteEqn' qn p a) (RewriteEqn' () q b) where+instance (ToConcrete p, ToConcrete a) => ToConcrete (RewriteEqn' qn A.BindName p a) where+  type ConOfAbs (RewriteEqn' qn A.BindName p a) = (RewriteEqn' () C.Name (ConOfAbs p) (ConOfAbs a))+   toConcrete = \case     Rewrite es    -> Rewrite <$> mapM (toConcrete . (\ (_, e) -> ((),e))) es-    Invert qn pes -> Invert () <$> mapM toConcrete pes+    Invert qn pes -> fmap (Invert ()) $ forM pes $ \ (Named n pe) -> do+      pe <- toConcrete pe+      n  <- toConcrete n+      pure $ Named n pe -instance ToConcrete (Maybe A.QName) (Maybe C.Name) where+instance ToConcrete (Maybe A.BindName) where+  type ConOfAbs (Maybe A.BindName) = Maybe C.Name+  toConcrete = traverse (C.boundName <.> toConcrete)++instance ToConcrete (Maybe A.QName) where+  type ConOfAbs (Maybe A.QName) = Maybe C.Name+   toConcrete = mapM (toConcrete . qnameName) -instance ToConcrete (Constr A.Constructor) C.Declaration where+instance ToConcrete (Constr A.Constructor) where+  type ConOfAbs (Constr A.Constructor) = C.Declaration+   toConcrete (Constr (A.ScopedDecl scope [d])) =     withScope scope $ toConcrete (Constr d)   toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do@@ -997,27 +1086,33 @@   toConcrete (Constr (A.Axiom _ _ _ (Just _) _ _)) = __IMPOSSIBLE__   toConcrete (Constr d) = head <$> toConcrete d -instance ToConcrete a C.LHS => ToConcrete (A.Clause' a) [C.Declaration] where+instance (ToConcrete a, ConOfAbs a ~ C.LHS) => ToConcrete (A.Clause' a) where+  type ConOfAbs (A.Clause' a) = [C.Declaration]+   toConcrete (A.Clause lhs _ rhs wh catchall) =       bindToConcrete lhs $ \case-          C.LHS p _ _ ell -> do+          C.LHS p _ _ -> do             bindToConcrete wh $ \ wh' -> do                 (rhs', eqs, with, wcs) <- toConcreteTop rhs-                return $ FunClause (C.LHS p eqs with ell) rhs' wh' catchall : wcs+                return $ FunClause (C.LHS p eqs with) rhs' wh' catchall : wcs -instance ToConcrete A.ModuleApplication C.ModuleApplication where+instance ToConcrete A.ModuleApplication where+  type ConOfAbs A.ModuleApplication = C.ModuleApplication+   toConcrete (A.SectionApp tel y es) = do     y  <- toConcreteCtx FunctionCtx y     bindToConcrete tel $ \ tel -> do       es <- toConcreteCtx argumentCtx_ es       let r = fuseRange y es-      return $ C.SectionApp r tel (foldl (C.App r) (C.Ident y) es)+      return $ C.SectionApp r (catMaybes tel) (foldl (C.App r) (C.Ident y) es)    toConcrete (A.RecordModuleInstance recm) = do     recm <- toConcrete recm     return $ C.RecordModuleInstance (getRange recm) recm -instance ToConcrete A.Declaration [C.Declaration] where+instance ToConcrete A.Declaration where+  type ConOfAbs A.Declaration = [C.Declaration]+   toConcrete (ScopedDecl scope ds) =     withScope scope (declsToConcrete ds) @@ -1052,8 +1147,8 @@     x' <- unsafeQNameToName <$> toConcrete x     withAbstractPrivate i $       withInfixDecl i x'  $ do-      t' <- toConcreteTop t-      return [C.Primitive (getRange i) [C.TypeSig defaultArgInfo Nothing x' t']]+      t' <- traverse toConcreteTop t+      return [C.Primitive (getRange i) [C.TypeSig (argInfo t') Nothing x' (unArg t')]]         -- Primitives are always relevant.    toConcrete (A.FunDef i _ _ cs) =@@ -1064,26 +1159,26 @@     bindToConcrete (A.generalizeTel bs) $ \ tel' -> do       x' <- unsafeQNameToName <$> toConcrete x       t' <- toConcreteTop t-      return [ C.DataSig (getRange i) x' (map C.DomainFull tel') t' ]+      return [ C.DataSig (getRange i) x' (map C.DomainFull $ catMaybes tel') t' ]    toConcrete (A.DataDef i x uc bs cs) =     withAbstractPrivate i $     bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do       (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)-      return [ C.DataDef (getRange i) x' tel' cs' ]+      return [ C.DataDef (getRange i) x' (catMaybes tel') cs' ]    toConcrete (A.RecSig i x bs t) =     withAbstractPrivate i $     bindToConcrete (A.generalizeTel bs) $ \ tel' -> do       x' <- unsafeQNameToName <$> toConcrete x       t' <- toConcreteTop t-      return [ C.RecordSig (getRange i) x' (map C.DomainFull tel') t' ]+      return [ C.RecordSig (getRange i) x' (map C.DomainFull $ catMaybes tel') t' ] -  toConcrete (A.RecDef  i x uc ind eta c bs t cs) =+  toConcrete (A.RecDef  i x uc dir bs t cs) =     withAbstractPrivate i $     bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do       (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)-      return [ C.RecordDef (getRange i) x' ind eta Nothing tel' cs' ]+      return [ C.RecordDef (getRange i) x' (dir { recConstructor = Nothing }) (catMaybes tel') cs' ]    toConcrete (A.Mutual i ds) = declsToConcrete ds @@ -1091,7 +1186,7 @@     x <- toConcrete x     bindToConcrete tel $ \ tel -> do       ds <- declsToConcrete ds-      return [ C.Module (getRange i) x tel ds ]+      return [ C.Module (getRange i) x (catMaybes tel) ds ]    toConcrete (A.Apply i x modapp _ _) = do     x  <- unsafeQNameToName <$> toConcrete x@@ -1117,7 +1212,9 @@    toConcrete (A.PatternSynDef x xs p) = do     C.QName x <- toConcrete x-    bindToConcrete xs $ \xs -> (:[]) . C.PatternSyn (getRange x) x xs <$> dontFoldPatternSynonyms (toConcrete (vacuous p :: A.Pattern))+    bindToConcrete (map (fmap A.unBind) xs) $ \ xs ->+      singleton . C.PatternSyn (getRange x) x xs <$> do+        dontFoldPatternSynonyms $ toConcrete (vacuous p :: A.Pattern)    toConcrete (A.UnquoteDecl _ i xs e) = do     let unqual (C.QName x) = return x@@ -1134,11 +1231,13 @@  data RangeAndPragma = RangeAndPragma Range A.Pragma -instance ToConcrete RangeAndPragma C.Pragma where+instance ToConcrete RangeAndPragma where+  type ConOfAbs RangeAndPragma = C.Pragma+   toConcrete (RangeAndPragma r p) = case p of     A.OptionsPragma xs  -> return $ C.OptionsPragma r xs     A.BuiltinPragma b x       -> C.BuiltinPragma r b <$> toConcrete x-    A.BuiltinNoDefPragma b x  -> C.BuiltinPragma r b <$> toConcrete x+    A.BuiltinNoDefPragma b _kind x -> C.BuiltinPragma r b <$> toConcrete x     A.RewritePragma r' x      -> C.RewritePragma r r' <$> toConcrete x     A.CompilePragma b x s -> do       x <- toConcrete x@@ -1152,15 +1251,20 @@  -- Left hand sides -------------------------------------------------------- -instance ToConcrete A.SpineLHS C.LHS where+instance ToConcrete A.SpineLHS where+  type ConOfAbs A.SpineLHS = C.LHS+   bindToConcrete lhs = bindToConcrete (A.spineToLhs lhs :: A.LHS) -instance ToConcrete A.LHS C.LHS where+instance ToConcrete A.LHS where+    type ConOfAbs A.LHS = C.LHS+     bindToConcrete (A.LHS i lhscore) ret = do       bindToConcreteCtx TopCtx lhscore $ \ lhs ->-          ret $ C.LHS (reintroduceEllipsis (lhsEllipsis i) lhs) [] [] NoEllipsis+          ret $ C.LHS (reintroduceEllipsis (lhsEllipsis i) lhs) [] [] -instance ToConcrete A.LHSCore C.Pattern where+instance ToConcrete A.LHSCore where+  type ConOfAbs A.LHSCore = C.Pattern   bindToConcrete = bindToConcrete . lhsCoreToPattern  appBracketsArgs :: [arg] -> PrecedenceStack -> Bool@@ -1173,13 +1277,16 @@ newtype BindingPattern = BindingPat A.Pattern newtype FreshenName = FreshenName BindName -instance ToConcrete FreshenName A.Name where+instance ToConcrete FreshenName where+  type ConOfAbs FreshenName = A.Name   bindToConcrete (FreshenName BindName{ unBind = x }) ret = bindToConcrete x $ \ y -> ret x { nameConcrete = y }  -- Pass 1: (Issue #2729) -- Takes care of binding the originally user-written pattern variables, but doesn't actually -- translate anything to Concrete.-instance ToConcrete (UserPattern A.Pattern) A.Pattern where+instance ToConcrete (UserPattern A.Pattern) where+  type ConOfAbs (UserPattern A.Pattern) = A.Pattern+   bindToConcrete (UserPattern p) ret = do     reportSLn "toConcrete.pat" 100 $ "binding pattern (pass 1)" ++ show p     case p of@@ -1208,15 +1315,20 @@                                 bindToConcrete (UserPattern p) $ \ p ->                                 ret (A.AsP i x p)       A.WithP i p            -> bindToConcrete (UserPattern p) $ ret . A.WithP i+      A.AnnP i a p           -> bindToConcrete (UserPattern p) $ ret . A.AnnP i a -instance ToConcrete (UserPattern (NamedArg A.Pattern)) (NamedArg A.Pattern) where+instance ToConcrete (UserPattern (NamedArg A.Pattern)) where+  type ConOfAbs (UserPattern (NamedArg A.Pattern)) = NamedArg A.Pattern+   bindToConcrete (UserPattern np) ret =     case getOrigin np of       CaseSplit -> ret np       _         -> bindToConcrete (fmap (fmap UserPattern) np) ret  -- Pass 2a: locate case-split pattern.  Don't bind anything!-instance ToConcrete (SplitPattern A.Pattern) A.Pattern where+instance ToConcrete (SplitPattern A.Pattern) where+  type ConOfAbs (SplitPattern A.Pattern) = A.Pattern+   bindToConcrete (SplitPattern p) ret = do     reportSLn "toConcrete.pat" 100 $ "binding pattern (pass 2a)" ++ show p     case p of@@ -1239,8 +1351,10 @@       A.AsP i x p            -> bindToConcrete (SplitPattern p)  $ \ p ->                                 ret (A.AsP i x p)       A.WithP i p            -> bindToConcrete (SplitPattern p) $ ret . A.WithP i+      A.AnnP i a p           -> bindToConcrete (SplitPattern p) $ ret . A.AnnP i a -instance ToConcrete (SplitPattern (NamedArg A.Pattern)) (NamedArg A.Pattern) where+instance ToConcrete (SplitPattern (NamedArg A.Pattern)) where+  type ConOfAbs (SplitPattern (NamedArg A.Pattern)) = NamedArg A.Pattern   bindToConcrete (SplitPattern np) ret =     case getOrigin np of       CaseSplit -> bindToConcrete (fmap (fmap BindingPat  ) np) ret@@ -1250,7 +1364,8 @@ -- Pass 2b: -- Takes care of freshening and binding pattern variables introduced by case split. -- Still does not translate anything to Concrete.-instance ToConcrete BindingPattern A.Pattern where+instance ToConcrete BindingPattern where+  type ConOfAbs BindingPattern = A.Pattern   bindToConcrete (BindingPat p) ret = do     reportSLn "toConcrete.pat" 100 $ "binding pattern (pass 2b)" ++ show p     case p of@@ -1269,8 +1384,11 @@                                 bindToConcrete (BindingPat p)  $ \ p ->                                 ret (A.AsP i (mkBindName x) p)       A.WithP i p            -> bindToConcrete (BindingPat p) $ ret . A.WithP i+      A.AnnP i a p           -> bindToConcrete (BindingPat p) $ ret . A.AnnP i a -instance ToConcrete A.Pattern C.Pattern where+instance ToConcrete A.Pattern where+  type ConOfAbs A.Pattern = C.Pattern+   bindToConcrete p ret = do     prec <- currentPrecedence     bindToConcrete (UserPattern p) $ \ p -> do@@ -1298,11 +1416,11 @@       A.AbsurdP i ->         return $ C.AbsurdP (getRange i) -      A.LitP (LitQName r x) -> do+      A.LitP i (LitQName x) -> do         x <- lookupQName AmbiguousNothing x-        bracketP_ appBrackets $ return $ C.AppP (C.QuoteP r) (defaultNamedArg (C.IdentP x))-      A.LitP l ->-        return $ C.LitP l+        bracketP_ appBrackets $ return $ C.AppP (C.QuoteP (getRange i)) (defaultNamedArg (C.IdentP x))+      A.LitP i l ->+        return $ C.LitP (getRange i) l        -- Andreas, 2018-06-19, issue #3130       -- Print .p as .(p) if p is a projection@@ -1321,7 +1439,7 @@         resolveName (someKindsOfNames [FldName]) Nothing (C.QName cn) >>= \ case           -- If we do then we print .(v) rather than .v           Right FieldName{} -> do-            reportSLn "print.dotted" 50 $ "Wrapping ambiguous name " ++ show (nameConcrete v)+            reportSLn "print.dotted" 50 $ "Wrapping ambiguous name " ++ prettyShow (nameConcrete v)             C.DotP r . C.Paren r <$> toConcrete (A.Var v)           Right _ -> printDotDefault i e           Left _ -> __IMPOSSIBLE__@@ -1338,6 +1456,8 @@        A.WithP i p -> C.WithP (getRange i) <$> toConcreteCtx WithArgCtx p +      A.AnnP i a p -> toConcrete p -- TODO: print type annotation+     where      printDotDefault :: PatInfo -> A.Expr -> AbsToCon C.Pattern@@ -1365,7 +1485,9 @@     applyTo args c = bracketP_ (appBracketsArgs args) $ do       foldl C.AppP c <$> toConcreteCtx argumentCtx_ args -instance ToConcrete (Maybe A.Pattern) (Maybe C.Pattern) where+instance ToConcrete (Maybe A.Pattern) where+  type ConOfAbs (Maybe A.Pattern) = Maybe C.Pattern+   toConcrete = traverse toConcrete  -- Helpers for recovering natural number literals@@ -1373,7 +1495,7 @@ tryToRecoverNatural :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr tryToRecoverNatural e def = do   is <- isBuiltinFun-  caseMaybe (recoverNatural is e) def $ return . C.Lit . LitNat noRange+  caseMaybe (recoverNatural is e) def $ return . C.Lit noRange . LitNat  recoverNatural :: (A.QName -> String -> Bool) -> A.Expr -> Maybe Integer recoverNatural is e = explore (`is` builtinZero) (`is` builtinSuc) 0 e@@ -1382,7 +1504,7 @@     explore isZero isSuc k (A.App _ (A.Con c) t) | Just f <- getUnambiguous c, isSuc f                                                 = (explore isZero isSuc $! k + 1) (namedArg t)     explore isZero isSuc k (A.Con c) | Just x <- getUnambiguous c, isZero x = Just k-    explore isZero isSuc k (A.Lit (LitNat _ l)) = Just (k + l)+    explore isZero isSuc k (A.Lit _ (LitNat l)) = Just (k + l)     explore _ _ _ _                             = Nothing  -- Helpers for recovering C.OpApp ------------------------------------------@@ -1412,17 +1534,18 @@ getHead (A.PatternSyn n) = Just (HdSyn $ headAmbQ n) getHead _                = Nothing -cOpApp :: Range -> C.QName -> A.Name -> [MaybeSection C.Expr] -> C.Expr+cOpApp :: Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr cOpApp r x n es =-  C.OpApp r x (Set.singleton n)-          (map (defaultNamedArg . placeholder) eps)+  C.OpApp r x (Set.singleton n) $+  fmap (defaultNamedArg . placeholder) $+  List1.toList eps   where     x0 = C.unqualify x-    positions | isPrefix  x0 =                [ Middle | _ <- drop 1 es ] ++ [End]-              | isPostfix x0 = [Beginning] ++ [ Middle | _ <- drop 1 es ]-              | isInfix x0   = [Beginning] ++ [ Middle | _ <- drop 2 es ] ++ [End]-              | otherwise    =                [ Middle | _ <- es ]-    eps = zip es positions+    positions | isPrefix  x0 =              (const Middle <$> List1.drop 1 es) `List1.snoc` End+              | isPostfix x0 = Beginning :| (const Middle <$> List1.drop 1 es)+              | isInfix x0   = Beginning :| (const Middle <$> List1.drop 2 es) ++ [ End ]+              | otherwise    =               const Middle <$> es+    eps = List1.zip es positions     placeholder (YesSection , pos ) = Placeholder pos     placeholder (NoSection e, _pos) = noPlaceholder (Ordinary e) @@ -1450,7 +1573,7 @@         sectionArgs :: [A.Name] -> [NamedArg (AppInfo, A.Expr)] -> Maybe [NamedArg (MaybeSection (AppInfo, A.Expr))]         sectionArgs xs = go xs           where-            noXs = getAll . foldExpr (\ case A.Var x -> All (notElem x xs)+            noXs = getAll . foldExpr (\ case A.Var x -> All (x `notElem` xs)                                              _       -> All True) . snd . namedArg             go [] [] = return []             go (y : ys) (arg : args)@@ -1475,23 +1598,24 @@   return res   where     opApp r x n ps = C.OpAppP r x (Set.singleton n) $-      map (defaultNamedArg . fromNoSection __IMPOSSIBLE__) ps+      fmap (defaultNamedArg . fromNoSection __IMPOSSIBLE__) $       -- `view` does not generate any `Nothing`s+      List1.toList ps      appInfo = defaultAppInfo_      view :: A.Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Pattern))])-    view p = case p of+    view = \case       ConP _        cs ps -> Just (HdCon (headAmbQ cs), (map . fmap . fmap) (NoSection . (appInfo,)) ps)       DefP _        fs ps -> Just (HdDef (headAmbQ fs), (map . fmap . fmap) (NoSection . (appInfo,)) ps)       PatternSynP _ ns ps -> Just (HdSyn (headAmbQ ns), (map . fmap . fmap) (NoSection . (appInfo,)) ps)       _                   -> Nothing       -- ProjP _ _ d   -> Just (HdDef (headAmbQ d), [])   -- ? Andreas, 2016-04-21 -recoverOpApp :: forall a c . (ToConcrete a c, HasRange c)+recoverOpApp :: forall a c . (ToConcrete a, c ~ ConOfAbs a, HasRange c)   => ((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)   -> (a -> Bool)  -- ^ Check for lambdas-  -> (Range -> C.QName -> A.Name -> [MaybeSection c] -> c)+  -> (Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)  -- ^ @opApp@   -> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))   -> a   -> AbsToCon (Maybe c)@@ -1528,62 +1652,55 @@     -- concrete name we choose! Make sure to resolve ambiguities with n'.     fx <- resolveName_ x [n'] <&> \ case             VarName y _                -> y ^. lensFixity-            DefinedName _ q            -> q ^. lensFixity+            DefinedName _ q _          -> q ^. lensFixity             FieldName (q :| _)         -> q ^. lensFixity-            ConstructorName (q :| _)   -> q ^. lensFixity+            ConstructorName _ (q :| _) -> q ^. lensFixity             PatternSynResName (q :| _) -> q ^. lensFixity             UnknownName                -> noFixity-    doQName fx x n' args (C.nameParts $ C.unqualify x)+    List1.ifNull args {-then-} mDefault {-else-} $ \ as ->+      doQName fx x n' as (C.nameParts $ C.unqualify x) -  doQName :: Fixity -> C.QName -> A.Name -> [MaybeSection (AppInfo, a)] -> [NamePart] -> AbsToCon (Maybe c)+  doQName :: Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> AbsToCon (Maybe c)    -- fall-back (wrong number of arguments or no holes)-  doQName _ x _ es xs-    | null es                 = mDefault-    | length es /= numHoles x = mDefault+  doQName _ x _ as xs+    | length as /= numHoles x = mDefault    -- binary case-  doQName fixity x n as xs-    | Hole <- head xs-    , Hole <- last xs = do-        let a1  = head as-            an  = last as-            as' = case as of-                    as@(_ : _ : _) -> init $ tail as-                    _              -> __IMPOSSIBLE__+  doQName fixity x n (a1 :| as) xs+    | Hole <- List1.head xs+    , Hole <- List1.last xs = do+        let (as', an) = List1.ifNull as {-then-} __IMPOSSIBLE__ {-else-} List1.initLast         Just <$> do           bracket (opBrackets' (skipParens an) fixity) $ do             e1 <- traverse (toConcreteCtx (LeftOperandCtx fixity) . snd) a1             es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'             en <- traverse (uncurry $ toConcreteCtx . RightOperandCtx fixity . appParens) an-            return $ opApp (getRange (e1, en)) x n ([e1] ++ es ++ [en])+            return $ opApp (getRange (e1, en)) x n (e1 :| es ++ [en])    -- prefix   doQName fixity x n as xs-    | Hole <- last xs = do-        let an  = last as-            as' = case as of-                    as@(_ : _) -> init as-                    _          -> __IMPOSSIBLE__+    | Hole <- List1.last xs = do+        let (as', an) = List1.initLast as         Just <$> do           bracket (opBrackets' (skipParens an) fixity) $ do             es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'             en <- traverse (\ (i, e) -> toConcreteCtx (RightOperandCtx fixity $ appParens i) e) an-            return $ opApp (getRange (n, en)) x n (es ++ [en])+            return $ opApp (getRange (n, en)) x n (List1.snoc es en)    -- postfix   doQName fixity x n as xs-    | Hole <- head xs = do-        let a1  = head as-            as' = tail as+    | Hole <- List1.head xs = do+        let a1  = List1.head as+            as' = List1.tail as         e1 <- traverse (toConcreteCtx (LeftOperandCtx fixity) . snd) a1         es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'         Just <$> do           bracket (opBrackets fixity) $-            return $ opApp (getRange (e1, n)) x n ([e1] ++ es)+            return $ opApp (getRange (e1, n)) x n (e1 :| es)    -- roundfix-  doQName _ x n as xs = do+  doQName _ x n as _ = do     es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as     Just <$> do       bracket roundFixBrackets $@@ -1616,10 +1733,10 @@   where apply c args = PatternSynP patNoRange (unambiguous c) args  -- | General pattern synonym recovery parameterised over expression type-recoverPatternSyn :: ToConcrete a c =>+recoverPatternSyn :: ToConcrete a =>   (A.QName -> [NamedArg a] -> a)         -> -- applySyn   (PatternSynDefn -> a -> Maybe [Arg a]) -> -- match-  a -> AbsToCon c -> AbsToCon c+  a -> AbsToCon (ConOfAbs a) -> AbsToCon (ConOfAbs a) recoverPatternSyn applySyn match e fallback = do   doFold <- asks foldPatternSynonyms   if not doFold then fallback else do@@ -1640,7 +1757,7 @@                 -- are already sorted from shortest to longest!                 , C.QName{} <- Fold.toList $ listToMaybe $ inverseScopeLookupName q scope                 ]-        cmp (_, _, x) (_, _, y) = flip compare x y+        cmp (_, _, x) (_, _, y) = compare y x     reportSLn "toConcrete.patsyn" 50 $ render $ hsep $       [ "Found pattern synonym candidates:"       , prettyList_ $ map (\ (q,_,_) -> q) cands@@ -1658,9 +1775,11 @@  -- Some instances that are related to interaction with users ----------- -instance ToConcrete InteractionId C.Expr where+instance ToConcrete InteractionId where+    type ConOfAbs InteractionId = C.Expr     toConcrete (InteractionId i) = return $ C.QuestionMark noRange (Just i) -instance ToConcrete NamedMeta C.Expr where+instance ToConcrete NamedMeta where+    type ConOfAbs NamedMeta = C.Expr     toConcrete i = do       return $ C.Underscore noRange (Just $ prettyShow i)

src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs view

@@ -1,2723 +1,3066 @@-{-# LANGUAGE TypeFamilies         #-}  -- for type equality ~-{-# LANGUAGE UndecidableInstances #-}--{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,-    figuring out infix operator precedences and tidying up definitions.--}-module Agda.Syntax.Translation.ConcreteToAbstract-    ( ToAbstract(..), localToAbstract-    , concreteToAbstract_-    , concreteToAbstract-    , NewModuleQName(..)-    , OldName(..)-    , TopLevel(..)-    , TopLevelInfo(..)-    , topLevelModuleName-    , AbstractRHS-    , NewModuleName, OldModuleName-    , NewName, OldQName-    , PatName, APatName-    ) where--import Prelude hiding ( mapM, null )--import Control.Applicative-import Control.Arrow (second)-import Control.Monad.Reader hiding (mapM)--import Data.Foldable (Foldable, traverse_)-import Data.Traversable (mapM, traverse)-import Data.Set (Set)-import Data.Map (Map)-import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Maybe-import Data.Void--import Agda.Syntax.Concrete as C hiding (topLevelModuleName)-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 ( patternVars, checkPatternLinearity )-import Agda.Syntax.Abstract.Pretty-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Position-import Agda.Syntax.Literal-import Agda.Syntax.Common-import Agda.Syntax.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)-import Agda.Syntax.DoNotation-import Agda.Syntax.IdiomBrackets--import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)-import Agda.TypeChecking.Monad.State-import Agda.TypeChecking.Monad.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.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.Either-import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.FileName-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 qualified Agda.Utils.Pretty as P-import Agda.Utils.Pretty (render, Pretty, pretty, prettyShow)-import Agda.Utils.Singleton-import Agda.Utils.Tuple--import Agda.Utils.Impossible-import Agda.ImpossibleTest (impossibleTest)--{---------------------------------------------------------------------------    Exceptions- --------------------------------------------------------------------------}---- notAModuleExpr e = typeError $ NotAModuleExpr e--notAnExpression :: C.Expr -> ScopeM A.Expr-notAnExpression e = typeError $ NotAnExpression e--nothingAppliedToHiddenArg :: C.Expr -> ScopeM A.Expr-nothingAppliedToHiddenArg e = typeError $ NothingAppliedToHiddenArg e--nothingAppliedToInstanceArg :: C.Expr -> ScopeM A.Expr-nothingAppliedToInstanceArg e = typeError $ NothingAppliedToInstanceArg e--notAValidLetBinding :: NiceDeclaration -> ScopeM a-notAValidLetBinding d = typeError $ NotAValidLetBinding d--{---------------------------------------------------------------------------    Helpers- --------------------------------------------------------------------------}---UNUSED Liang-Ting Chen 2019-07-16---annotateDecl :: ScopeM A.Declaration -> ScopeM A.Declaration---annotateDecl m = annotateDecls $ (:[]) <$> m--annotateDecls :: ScopeM [A.Declaration] -> ScopeM A.Declaration-annotateDecls m = do-  ds <- m-  s  <- getScope-  return $ ScopedDecl s ds--annotateExpr :: ScopeM A.Expr -> ScopeM A.Expr-annotateExpr m = do-  e <- m-  s <- getScope-  return $ ScopedExpr s e---- | Make sure that there are no dot patterns (called on pattern synonyms).-noDotorEqPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)-noDotorEqPattern err = dot-  where-    dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)-    dot p = case p of-      A.VarP x               -> pure $ A.VarP x-      A.ConP i c args        -> A.ConP i c <$> (traverse $ traverse $ traverse dot) args-      A.ProjP i o d          -> pure $ A.ProjP i o d-      A.WildP i              -> pure $ A.WildP i-      A.AsP i x p            -> A.AsP i x <$> dot p-      A.DotP{}               -> genericError err-      A.EqualP{}             -> genericError err   -- Andrea: so we also disallow = patterns, reasonable?-      A.AbsurdP i            -> pure $ A.AbsurdP i-      A.LitP l               -> pure $ A.LitP l-      A.DefP i f args        -> A.DefP i f <$> (traverse $ traverse $ traverse dot) args-      A.PatternSynP i c args -> A.PatternSynP i c <$> (traverse $ traverse $ traverse dot) args-      A.RecP i fs            -> A.RecP i <$> (traverse $ traverse dot) fs-      A.WithP i p            -> A.WithP i <$> dot p---UNUSED Liang-Ting Chen 2019-07-16----- | Make sure that there are no dot patterns (WAS: called on pattern synonyms).---noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)---noDotPattern err = traverse $ const $ genericError err--newtype RecordConstructorType = RecordConstructorType [C.Declaration]--instance ToAbstract RecordConstructorType A.Expr where-  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-    buildType ds = do-      tel <- mapM makeBinding ds  -- TODO: Telescope instead of Expr in abstract RecDef-      return $ A.Pi (ExprRange (getRange ds)) tel (A.Set exprNoRange 0)--    makeBinding :: C.NiceDeclaration -> ScopeM A.TypedBinding-    makeBinding d = do-      let failure = typeError $ NotValidBeforeField d-          r       = getRange d-          info    = ExprRange r-          mkLet d = A.TLet r <$> toAbstract (LetDef d)-      traceCall (SetRange r) $ case d of--        C.NiceField r pr ab inst tac x a -> do-          fx  <- getConcreteFixity x-          let bv = unnamed (C.mkBinder $ (C.mkBoundName x fx) { bnameTactic = tac }) <$ a-          tel <- toAbstract $ C.TBind r [bv] (unArg a)-          return tel--        -- 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 x modapp open dir -> do-          mkLet $ C.NiceModuleMacro r p 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 [] [] NoEllipsis) (C.RHS _) NoWhere [] ]-          ] | abstract /= AbstractDef && macro /= MacroDef -> do-          mkLet d--        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--checkModuleApplication-  :: C.ModuleApplication-  -> ModuleName-  -> C.Name-  -> C.ImportDirective-  -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)--checkModuleApplication (C.SectionApp _ tel e) 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-    -- Check that expression @e@ is of the form @m args@.-    (m, args) <- parseModuleApplication e-    -- Scope check the telescope (introduces bindings!).-    tel' <- 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" 20 "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" 20 "copied record module"-    return (A.RecordModuleInstance m1, copyInfo, adir)---- | @checkModuleMacro mkApply range access concreteName modapp open dir@------   Preserves local variables.--checkModuleMacro-  :: (Pretty c, ToConcrete a c)-  => (ModuleInfo-      -> ModuleName-      -> A.ModuleApplication-      -> ScopeCopyInfo-      -> A.ImportDirective-      -> a)-  -> OpenKind-  -> Range-  -> Access-  -> C.Name-  -> C.ModuleApplication-  -> OpenShortHand-  -> C.ImportDirective-  -> ScopeM [a]-checkModuleMacro apply kind r p 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" 20 "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" 20 "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" 20 "after copying"--    -- Open the module if DoOpen.-    -- Andreas, 2014-09-02: @openModule@ might shadow some locals!-    adir <- case open of-      DontOpen -> return adir'-      DoOpen   -> openModule kind (Just m0) (C.QName x) openDir-    printScope "mod.inst" 20 $ show open-    reportSDoc "scope.decl" 90 $ "after open   : m0 =" <+> prettyA m0--    stripNoNames-    printScope "mod.inst" 10 $ "after stripping"-    reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0--    let m      = m0 `withRangesOf` [x]-        adecls = [ apply info 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 $ vcat $-      map (nest 2 . prettyA) adecls-    return adecls-  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   dir = return dir-notPublicWithoutOpen DontOpen dir = do-  whenJust (publicOpen dir) $ \ r ->-    setCurrentRange r $ warning UselessPublic-  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-  reportSDoc "scope.decl" 70 $ do-    cm <- getCurrentModule-    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`-  whenJust (publicOpen dir) $ \ r -> do-    whenM ((A.noModuleName ==) <$> getCurrentModule) $ do-      setCurrentRange r $ warning UselessPublic--  m <- caseMaybe mam (toAbstract (OldModuleName x)) return-  printScope "open" 20 $ "opening " ++ prettyShow x-  adir <- openModule TopOpenModule (Just m) x dir-  printScope "open" 20 $ "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)--{---------------------------------------------------------------------------    Translation- --------------------------------------------------------------------------}--concreteToAbstract_ :: ToAbstract c a => c -> ScopeM a-concreteToAbstract_ = toAbstract--concreteToAbstract :: ToAbstract c a => ScopeInfo -> c -> ScopeM a-concreteToAbstract scope x = withScope_ scope (toAbstract x)---- | Things that can be translated to abstract syntax are instances of this---   class.-class ToAbstract concrete abstract | concrete -> abstract where-    toAbstract :: concrete -> ScopeM abstract---- | 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 concrete abstract =>-                 Precedence -> concrete -> ScopeM abstract-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 a) => h -> c -> ScopeM a-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 concrete abstract =>---                     Precedence -> concrete -> (abstract -> ScopeM a) -> ScopeM a---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 a => c -> (a -> ScopeM b) -> ScopeM b-localToAbstract x ret = fst <$> localToAbstract' x ret---- | Like 'localToAbstract' but returns the scope after the completion of the---   second argument.-localToAbstract' :: ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM (b, ScopeInfo)-localToAbstract' x ret = do-  scope <- getScope-  withScope scope $ ret =<< toAbstract x--instance ToAbstract () () where-  toAbstract = pure--instance (ToAbstract c1 a1, ToAbstract c2 a2) => ToAbstract (c1,c2) (a1,a2) where-  toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y--instance (ToAbstract c1 a1, ToAbstract c2 a2, ToAbstract c3 a3) =>-         ToAbstract (c1,c2,c3) (a1,a2,a3) where-    toAbstract (x,y,z) = flatten <$> toAbstract (x,(y,z))-        where-            flatten (x,(y,z)) = (x,y,z)--instance {-# OVERLAPPABLE #-} ToAbstract c a => ToAbstract [c] [a] where-  toAbstract = mapM toAbstract--instance (ToAbstract c1 a1, ToAbstract c2 a2) =>-         ToAbstract (Either c1 c2) (Either a1 a2) where-    toAbstract = traverseEither toAbstract toAbstract--instance ToAbstract c a => ToAbstract (Maybe c) (Maybe a) where-  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 (Set 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--newtype OldName a = OldName a---- | Wrapper to resolve a name to a 'ResolvedName' (rather than an 'A.Expr').-data ResolveQName = ResolveQName C.QName--data PatName      = PatName C.QName (Maybe (Set A.Name))-  -- ^ If a set is given, then the first name must correspond to one-  -- of the names in the set.--instance ToAbstract (NewName C.Name) A.Name where-  toAbstract (NewName b x) = do-    y <- freshAbstractName_ x-    bindVariable b x y-    return y--instance ToAbstract (NewName C.BoundName) A.BindName where-  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 A.Expr where-  toAbstract q@(OldQName x _) =-    fromMaybeM (notInScopeError x) $ toAbstract (MaybeOldQName q)--instance ToAbstract MaybeOldQName (Maybe A.Expr) where-  toAbstract (MaybeOldQName (OldQName x ns)) = do-    qx <- resolveName' allKindsOfNames ns x-    reportSLn "scope.name" 10 $ "resolved " ++ prettyShow x ++ ": " ++ prettyShow qx-    case qx of-      VarName x' _         -> return $ Just $ A.Var x'-      DefinedName _ d      -> do-        -- In case we find a defined name, we start by checking whether there's-        -- a warning attached to it-        reportSDoc "scope.warning" 50 $ text $ "Checking usage of " ++ prettyShow d-        mstr <- Map.lookup (anameName d) <$> getUserWarnings-        forM_ mstr (warning . UserWarning)-        -- then we take note of generalized names used-        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 -> do-            typeError . GenericDocError =<<-              text "Cannot use generalized variable from let-opened module:" <+> prettyTCM (anameName d)-          _ -> return ()-        -- and then we return the name-        return $ Just $ nameToExpr d-      FieldName     ds     -> return $ Just $ A.Proj ProjPrefix $ AmbQ (fmap anameName ds)-      ConstructorName ds   -> return $ Just $ A.Con $ AmbQ (fmap anameName ds)-      UnknownName          -> pure Nothing-      PatternSynResName ds -> return $ Just $ A.PatternSyn $ AmbQ (fmap anameName ds)--instance ToAbstract ResolveQName ResolvedName where-  toAbstract (ResolveQName x) = resolveName x >>= \case-    UnknownName -> notInScopeError x-    q -> return q--data APatName = VarPatName A.Name-              | ConPatName (NonEmpty AbstractName)-              | PatternSynPatName (NonEmpty AbstractName)--instance ToAbstract PatName APatName where-  toAbstract (PatName x ns) = do-    reportSLn "scope.pat" 10 $ "checking pattern name: " ++ prettyShow x-    rx <- resolveName' (someKindsOfNames [ConName, PatternSynName]) ns x-          -- Andreas, 2013-03-21 ignore conflicting names which cannot-          -- be meant since we are in a pattern-    case (rx, x) of-      (VarName y _,     C.QName x)                          -> bindPatVar x-      (FieldName d,     C.QName x)                          -> bindPatVar x-      (DefinedName _ d, C.QName x) | isDefName (anameKind d)-> bindPatVar x-      (UnknownName,     C.QName x)                          -> bindPatVar x-      (ConstructorName ds, _)                               -> patCon ds-      (PatternSynResName d, _)                              -> patSyn d-      _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x-    where-      bindPatVar = VarPatName <.> bindPatternVariable-      patCon ds = do-        reportSLn "scope.pat" 10 $ "it was a con: " ++ prettyShow (fmap anameName ds)-        return $ ConPatName ds-      patSyn ds = do-        reportSLn "scope.pat" 10 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds)-        return $ PatternSynPatName ds---- | Translate and possibly bind a pattern variable---   (which could have been bound before due to non-linearity).-bindPatternVariable :: C.Name -> ScopeM A.Name-bindPatternVariable x = do-  reportSLn "scope.pat" 10 $ "it was a var: " ++ prettyShow x-  y <- (AssocList.lookup x <$> getVarsToBind) >>= \case-    Just (LocalVar y _ _) -> return $ setRange (getRange x) y-    Nothing -> freshAbstractName_ x-  addVarToBind x $ LocalVar y PatternBound []-  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 (Show a, ToQName a) => ToAbstract (OldName a) A.QName where-  toAbstract (OldName x) = do-    rx <- resolveName (toQName x)-    case rx of-      DefinedName _ d      -> return $ anameName d-      -- We can get the cases below for DISPLAY pragmas-      ConstructorName ds   -> return $ anameName (NonEmpty.head ds)   -- We'll throw out this one, so it doesn't matter which one we pick-      FieldName ds         -> return $ anameName (NonEmpty.head ds)-      PatternSynResName ds -> return $ anameName (NonEmpty.head ds)-      VarName x _          -> genericError $ "Not a defined name: " ++ prettyShow x-      UnknownName          -> notInScopeError (toQName x)--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 . mnameFromList . (:[]) <$> freshAbstractName_ x--checkForModuleClash :: C.Name -> ScopeM ()-checkForModuleClash x = do-  ms :: [AbstractModule] <- scopeLookup (C.QName x) <$> getScope-  unless (null ms) $ do-    reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ prettyShow ms-    reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms-    setCurrentRange x $-      typeError $ ShadowedModule x $-                map ((`withRangeOf` x) . amodName) ms--instance ToAbstract NewModuleName A.ModuleName where-  toAbstract (NewModuleName x) = do-    checkForModuleClash x-    m <- getCurrentModule-    y <- freshQModule m x-    createModule Nothing y-    return y--instance ToAbstract NewModuleQName A.ModuleName where-  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 A.ModuleName where-  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---UNUSED Liang-Ting 2019-07-16----- | By default, arguments are @Relevant@.---mkArg :: C.Expr -> Arg C.Expr---mkArg e = mkArg' defaultArgInfo e--inferParenPreference :: C.Expr -> ParenPreference-inferParenPreference C.Paren{} = PreferParen-inferParenPreference _         = PreferParenless---- | Parse a possibly dotted @C.Expr@ as @A.Expr@, interpreting dots as relevance.-toAbstractDot :: Precedence -> C.Expr -> ScopeM (A.Expr, Relevance)-toAbstractDot prec e = do-    reportSLn "scope.irrelevance" 100 $ "toAbstractDot: " ++ (render $ pretty e)-    traceCall (ScopeCheckExpr e) $ case e of--      C.RawApp _ es   -> toAbstractDot prec =<< parseApplication es-      C.Paren _ e     -> toAbstractDot TopCtx e-      C.Dot _ e       -> (,Irrelevant) <$> toAbstractCtx prec e-      C.DoubleDot _ e -> (,NonStrict)  <$> toAbstractCtx prec e-      e               -> (,Relevant)   <$> toAbstractCtx prec e---- | Translate concrete expression under at least one binder into nested---   lambda abstraction in abstract syntax.-toAbstractLam :: Range -> [C.LamBinding] -> C.Expr -> Precedence -> ScopeM A.Expr-toAbstractLam r bs e ctx = do-  -- Translate the binders-  lvars0 <- getLocalVars-  localToAbstract (map (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@.-    caseList bs __IMPOSSIBLE__ $ \ b bs -> do-      return $ A.Lam (ExprRange r) b $ foldr mkLam e bs-  where-    mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e---- | Scope check extended lambda expression.-scopeCheckExtendedLam :: Range -> [C.LamClause] -> ScopeM A.Expr-scopeCheckExtendedLam r cs = do-  whenM isInsideDotPattern $-    genericError "Extended lambdas are not allowed in dot patterns"--  -- Find an unused name for the extended lambda definition.-  cname <- freshConcreteName r 0 extendedLambdaName-  name  <- freshAbstractName_ cname-  a <- asksTC (^. lensIsAbstract)-  reportSDoc "scope.extendedLambda" 10 $ 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 (PrivateAccess Inserted) FunName cname qname--  -- Compose a function definition and scope check it.-  let-    insertApp :: C.Pattern -> ScopeM C.Pattern-    insertApp (C.RawAppP r es) = return $ C.RawAppP r $ IdentP (C.QName cname) : es-    insertApp (C.AppP p1 p2)   = return $ (IdentP (C.QName cname) `C.AppP` defaultNamedArg p1) `C.AppP` p2  -- Case occurs in issue #2785-    insertApp p = return $ C.RawAppP r $ IdentP (C.QName cname) : [p] -- Issue #2807: C.ParenP also possible-      where r = getRange p-      -- Andreas, 2017-10-17 issue #2807: do not raise IMPOSSSIBLE here-      -- since we are actually not sure what is possible and what not.--    -- insertApp (C.IdentP q    ) = return $ C.RawAppP r $ IdentP (C.QName cname) : [C.IdentP q]-    --   where r = getRange q-    -- insertApp p = do-    --   reportSLn "impossible" 10 $ "scopeCheckExtendedLam: unexpected pattern: " ++-    --     case p of-    --       C.QuoteP{}    -> "QuoteP"-    --       C.OpAppP{}    -> "OpAppP"-    --       C.HiddenP{}   -> "HiddenP"-    --       C.InstanceP{} -> "InstanceP"-    --       C.ParenP{}    -> "ParenP"-    --       C.WildP{}     -> "WildP"-    --       C.AbsurdP{}   -> "AbsurdP"-    --       C.AsP{}       -> "AsP"-    --       C.DotP{}      -> "DotP"-    --       C.LitP{}      -> "LitP"-    --       C.RecP{}      -> "RecP"-    --       _ -> __IMPOSSIBLE__-    --   __IMPOSSIBLE__--  -- 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 <$> do-          forM cs $ \ (LamClause lhs rhs wh ca) -> do -- wh == NoWhere, see parser for more info-            lhs' <- mapLhsOriginalPatternM insertApp lhs-            return $ C.Clause cname ca lhs' rhs wh []-  scdef <- toAbstract d--  -- Create the abstract syntax for the extended lambda.-  case scdef of-    A.ScopedDecl si [A.FunDef di qname' NotDelayed cs] -> do-      setScope si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...-      return $ A.ExtendedLam (ExprRange r) di qname' cs-    _ -> __IMPOSSIBLE__---- | Scope check an expression.--instance ToAbstract C.Expr A.Expr where-  toAbstract e =-    traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of--  -- Names-      Ident x -> toAbstract (OldQName x Nothing)--  -- Literals-      C.Lit l ->-        case l of-          LitNat r n -> do-            let builtin | n < 0     = Just <$> primFromNeg    -- negative literals are only allowed if FROMNEG is defined-                        | otherwise = ensureInScope =<< getBuiltin' builtinFromNat-                l'   = LitNat r (abs n)-                info = defaultAppInfo r-            conv <- builtin-            case conv of-              Just (I.Def q _) -> return $ A.App info (A.Def q) $ defaultNamedArg (A.Lit l')-              _                -> return $ A.Lit l--          LitString r s -> do-            conv <- ensureInScope =<< getBuiltin' builtinFromString-            let info = defaultAppInfo r-            case conv of-              Just (I.Def q _) -> return $ A.App info (A.Def q) $ defaultNamedArg (A.Lit l)-              _                -> return $ A.Lit l--          _ -> return $ A.Lit l-        where-          ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)-          ensureInScope v@(Just (I.Def q _)) = ifM (isNameInScope 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 = ""-             }-        return $ A.QuestionMark info ii-      C.Underscore r n -> do-        scope <- getScope-        return $ A.Underscore $ MetaInfo-                    { metaRange  = r-                    , metaScope  = scope-                    , metaNumber = maybe Nothing __IMPOSSIBLE__ n-                    , metaNameSuggestion = fromMaybe "" n-                    }--  -- Raw application-      C.RawApp r es -> do-        e <- parseApplication es-        toAbstract e--  -- Application-      C.App r e1 e2 -> do-        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--  -- 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-      C.HiddenArg _ _ -> nothingAppliedToHiddenArg e-      C.InstanceArg _ _ -> nothingAppliedToInstanceArg 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 cs -> scopeCheckExtendedLam r cs--  -- Relevant and irrelevant non-dependent function type-      C.Fun r (Arg info1 e1) e2 -> do-        Arg info (e1', rel) <- traverse (toAbstractDot FunctionSpaceDomainCtx) $ mkArg' info1 e1-        let updRel = case rel of-              Relevant -> id-              rel      -> setRelevance rel-        A.Fun (ExprRange r) (Arg (updRel 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.Pi info tel e--  -- Sorts-      C.Set _    -> return $ A.Set (ExprRange $ getRange e) 0-      C.SetN _ n -> return $ A.Set (ExprRange $ getRange e) n-      C.Prop _   -> return $ A.Prop (ExprRange $ getRange e) 0-      C.PropN _ n -> return $ A.Prop (ExprRange $ getRange e) n--  -- Let-      e0@(C.Let _ ds (Just e)) ->-        ifM isInsideDotPattern (genericError $ "Let-expressions are not allowed in dot patterns") $-        localToAbstract (LetDefs ds) $ \ds' -> do-          e <- toAbstractCtx TopCtx e-          let info = ExprRange (getRange e0)-          return $ A.Let info ds' e-      C.Let _ _ Nothing -> genericError "Missing body in let-expression"--  -- Record construction-      C.Rec r fs  -> do-        fs' <- toAbstractCtx TopCtx fs-        let ds'  = [ d | Right (_, ds) <- fs', d <- ds ]-            fs'' = map (mapRight fst) fs'-            i    = ExprRange r-        return $ A.mkLet i ds' (A.Rec i fs'')--  -- Record update-      C.RecUpdate r e fs -> do-        A.RecUpdate (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-      C.Dot r e  -> A.Dot (ExprRange r) <$> toAbstract e--  -- Pattern things-      C.As _ _ _ -> notAnExpression e-      C.Absurd _ -> notAnExpression e--  -- Impossible things-      C.ETel _  -> __IMPOSSIBLE__-      C.Equal{} -> genericError "Parse error: unexpected '='"-      C.Ellipsis _ -> genericError "Parse error: unexpected '...'"-      C.DoubleDot _ _ -> genericError "Parse error: unexpected '..'"--  -- 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 -> do-        let AppView e' args = appView e-        e'   <- toAbstract e'-        args <- toAbstract args-        return $ A.Tactic (ExprRange r) e' args--  -- 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 (A.ModuleName, [A.LetBinding]) where-  toAbstract (C.ModuleAssignment m es i)-    | null es && isDefaultImportDir i = (, []) <$> toAbstract (OldModuleName m)-    | otherwise = do-        x <- C.NoName (getRange m) <$> fresh-        r <- checkModuleMacro LetApply LetOpenModule (getRange (m, es, i)) PublicAccess x-                          (C.SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))-                          DontOpen i-        case r of-          (LetApply _ m' _ _ _ : _) -> return (m', r)-          _ -> __IMPOSSIBLE__--instance ToAbstract c a => ToAbstract (FieldAssignment' c) (FieldAssignment' a) where-  toAbstract = traverse toAbstract--instance ToAbstract (C.Binder' (NewName C.BoundName)) A.Binder where-  toAbstract (C.Binder p 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.-    n <- if not (isNoName name && isJust p) then pure n else do-           n' <- freshConcreteName (getRange $ newName n) 0 patternInTeleName-           pure $ fmap (\ n -> n { C.boundName = n' }) n-    n <- toAbstract n-    -- 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 n--instance ToAbstract C.LamBinding A.LamBinding where-  toAbstract (C.DomainFree x)  = do-    tac <- traverse toAbstract $ bnameTactic $ C.binderName $ namedArg x-    A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)-  toAbstract (C.DomainFull tb) = A.DomainFull <$> toAbstract tb--makeDomainFull :: C.LamBinding -> C.TypedBinding-makeDomainFull (C.DomainFull b) = b-makeDomainFull (C.DomainFree x) = C.TBind r [x] $ C.Underscore r Nothing-  where r = getRange x--instance ToAbstract C.TypedBinding A.TypedBinding where-  toAbstract (C.TBind r xs t) = do-    t' <- toAbstractCtx TopCtx t-    tac <- traverse toAbstract $-             case mapMaybe (bnameTactic . C.binderName . namedArg) xs of-               []      -> Nothing-               tac : _ -> Just tac-               -- Invariant: all tactics are the same-               -- (distributed in the parser, TODO: don't)-    xs' <- toAbstract $ map (updateNamedArg (fmap $ NewName LambdaBound)) xs-    return $ A.TBind r tac xs' t'-  toAbstract (C.TLet r ds) = A.TLet r <$> toAbstract (LetDefs ds)---- | Scope check a module (top level function).----scopeCheckNiceModule-  :: Range-  -> Access-  -> C.Name-  -> C.Telescope-  -> ScopeM [A.Declaration]-  -> ScopeM [A.Declaration]-scopeCheckNiceModule r p name tel checkDs-  | telHasOpenStmsOrModuleMacros tel = do-      -- 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!-      scopeCheckNiceModule noRange p noName_ [] $-        scopeCheckNiceModule_--  | otherwise = do-        scopeCheckNiceModule_-  where-    -- The actual workhorse:-    scopeCheckNiceModule_ = 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, PrivateAccess Inserted, True)-         else return (name, p, False)--      -- Check and bind the module, using the supplied check for its contents.-      aname <- toAbstract (NewModuleName name)-      ds <- snd <$> do-        scopeCheckModule r (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) noRange }-      return ds---- | Check whether a telescope has open declarations or module macros.-telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool-telHasOpenStmsOrModuleMacros = any yesBind-  where-    yesBind C.TBind{}     = False-    yesBind (C.TLet _ ds) = any yes ds-    yes C.ModuleMacro{}   = True-    yes C.Open{}          = True-    yes 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)-    yes (C.Mutual   _ ds) = any yes ds-    yes (C.Abstract _ ds) = any yes ds-    yes (C.Private _ _ ds) = any yes ds-    yes _                 = False--{- UNUSED-telHasLetStms :: C.Telescope -> Bool-telHasLetStms = any isLetBind-  where-    isLetBind C.TBind{} = False-    isLetBind C.TLet{}  = True--}---- | 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-  -> 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])-scopeCheckModule r x qm tel checkDs = do-  printScope "module" 20 $ "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" 20 $ "inside module " ++ prettyShow x-      ds    <- checkDs-      scope <- getScope-      return (scope, [ A.Section info (qm `withRangesOfQ` x) tel ds ])--  -- Binding is done by the caller-  printScope "module" 20 $ "after module " ++ prettyShow x-  return res-  where-    info = ModuleInfo r noRange Nothing Nothing Nothing---- | Temporary data type to scope check a file.-data TopLevel a = TopLevel-  { topLevelPath           :: AbsolutePath-    -- ^ The file path from which we loaded this module.-  , topLevelExpectedName   :: C.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]) TopLevelInfo where-    toAbstract (TopLevel file 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 : _) -> traceCall (SetRange $ getRange d) $-          genericError $ "No declarations allowed after top-level module."--        -- Otherwise, proceed.-        (outsideDecls, [ C.Module r m0 tel insideDecls ]) -> do-          -- If the module name is _ compute the name from the file path-          m <- if isNoName m0-                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 _ _ : _))-                       | C.toTopLevelModuleName m1 == 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--                         traceCall (SetRange $ getRange ds0) $ genericError-                           "Illegal declaration(s) before top-level module"--                    -- Otherwise, reconstruct the top-level module name-                    _ -> return $ C.QName $ C.Name (getRange m0) C.InScope-                           [Id $ stringToRawName $ rootNameModule file]-                -- 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.-                  checkModuleName (C.toTopLevelModuleName m0) (SourceFile file) $ Just expectedMName-                  return m0-          setTopLevelModule m-          am           <- toAbstract (NewModuleQName m)-          -- Scope check the declarations outside-          outsideDecls <- toAbstract outsideDecls-          (insideScope, insideDecls) <- scopeCheckModule r m am tel $-             toAbstract insideDecls-          let scope = over scopeModules (fmap $ restrictLocalPrivate am) insideScope-          setScope scope-          return $ TopLevelInfo (outsideDecls ++ insideDecls) scope--        -- We already inserted the missing top-level module, see-        -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',-        -- thus, this case is impossible:-        _ -> __IMPOSSIBLE__---- | 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-  fixs <- useScope scopeFixities  -- We need to pass the fixities to the nicifier for clause grouping-  let (result, warns') = runNice $ niceDeclarations fixs ds--  -- COMPILED pragmas are not allowed in safe mode unless we are in a builtin module.-  -- So we start by filtering out all the PragmaCompiled warnings if one of these two-  -- conditions is not met.-  isSafe    <- Lens.getSafeMode <$> pragmaOptions-  isBuiltin <- Lens.isBuiltinModule . filePath =<< getCurrentPath-  let warns = if isSafe && not isBuiltin then warns' else filter notOnlyInSafeMode warns'--  -- 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-      unless (null errs) $ do-        warnings $ NicifierIssue <$> ws-        tcerrs <- mapM warning_ $ NicifierIssue <$> errs-        setCurrentRange errs $ typeError $ NonFatalErrors tcerrs-    -- Otherwise we simply record the warnings-    warnings $ NicifierIssue <$> warns-  case result of-    Left e   -> throwError $ Exception (getRange e) $ pretty e-    Right ds -> ret ds--  where notOnlyInSafeMode = (PragmaCompiled_ /=) . declarationWarningName--instance {-# OVERLAPPING #-} ToAbstract [C.Declaration] [A.Declaration] where-  toAbstract ds = do-    -- When --safe is active the termination checker (Issue 586),-    -- positivity checker (Issue 1614) and the coverage checker-    -- may not be switched off, and polarities may not be assigned.-    ds <- ifM (Lens.getSafeMode <$> pragmaOptions)-               {- then -} (mapM noUnsafePragma ds)-               {- else -} (return ds)--    niceDecls DoWarn ds toAbstract-   where--     -- We need to dig deep into a declaration, otherwise it is possible-     -- to hide an illegal pragma in a block. Cf. Issue #3983-     noUnsafePragma :: C.Declaration -> TCM C.Declaration-     noUnsafePragma = \case-       C.Pragma pr                         -> warnUnsafePragma pr-       C.RecordDef r n ind eta ins lams ds -> C.RecordDef r n ind eta ins lams <$> mapM noUnsafePragma ds-       C.Record r n ind eta ins lams e ds  -> C.Record r n ind eta ins lams e <$> mapM noUnsafePragma ds-       C.Mutual r ds                       -> C.Mutual r <$> mapM noUnsafePragma ds-       C.Abstract r ds                     -> C.Abstract r <$> mapM noUnsafePragma ds-       C.Private r o ds                    -> C.Private r o <$> mapM noUnsafePragma ds-       C.InstanceB r ds                    -> C.InstanceB r <$> mapM noUnsafePragma ds-       C.Macro r ds                        -> C.Macro r <$> mapM noUnsafePragma ds-       d -> pure d--     warnUnsafePragma :: C.Pragma -> TCM C.Declaration-     warnUnsafePragma pr = C.Pragma pr <$ do-       ifM (Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath)-         {- then -} (pure ())-         {- else -} $ case unsafePragma pr of-         Nothing -> pure ()-         Just w  -> setCurrentRange pr $ warning w--     unsafePragma :: C.Pragma -> Maybe Warning-     unsafePragma = \case-       C.NoCoverageCheckPragma{}    -> Just SafeFlagNoCoverageCheck-       C.NoPositivityCheckPragma{}  -> Just SafeFlagNoPositivityCheck-       C.PolarityPragma{}           -> Just SafeFlagPolarity-       C.NoUniverseCheckPragma{}    -> Just SafeFlagNoUniverseCheck-       C.InjectivePragma{}          -> Just SafeFlagInjective-       C.TerminationCheckPragma _ m -> case m of-         NonTerminating       -> Just SafeFlagNonTerminating-         Terminating          -> Just SafeFlagTerminating-         TerminationCheck     -> Nothing-         TerminationMeasure{} -> Nothing-         -- ASR (31 December 2015). We don't pattern-match on-         -- @NoTerminationCheck@ because the @NO_TERMINATION_CHECK@ pragma-         -- was removed. See Issue #1763.-         NoTerminationCheck -> Nothing-       -- exhaustive match to get told by ghc we should have a look at this-       -- when we add new pragmas.-       C.OptionsPragma{}    -> Nothing-       C.BuiltinPragma{}    -> Nothing-       C.ForeignPragma{}    -> Nothing-       C.StaticPragma{}     -> Nothing-       C.InlinePragma{}     -> Nothing-       C.ImpossiblePragma{} -> Nothing-       C.EtaPragma{}        -> Just SafeFlagEta-       C.WarningOnUsage{}   -> Nothing-       C.WarningOnImport{}  -> Nothing-       C.DisplayPragma{}    -> Nothing-       C.CatchallPragma{}   -> Nothing-       -- @RewritePragma@ already requires --rewriting which is incompatible with --safe-       C.RewritePragma{}    -> Nothing-       -- @CompilePragma@ already handled in the nicifier-       C.CompilePragma{}    -> Nothing---newtype LetDefs = LetDefs [C.Declaration]-newtype LetDef = LetDef NiceDeclaration--instance ToAbstract LetDefs [A.LetBinding] where-  toAbstract (LetDefs ds) =-    concat <$> (niceDecls DoWarn ds $ toAbstract . map LetDef)--instance ToAbstract LetDef [A.LetBinding] where-  toAbstract (LetDef d) =-    case d of-      NiceMutual _ _ _ _ d@[C.FunSig _ _ _ instanc macro info _ _ x t, C.FunDef _ _ abstract _ _ _ _ [cl]] ->-          do  when (abstract == AbstractDef) $ do-                genericError $ "abstract not allowed in let expressions"-              when (macro == MacroDef) $ do-                genericError $ "Macros cannot be defined in a let expression."-              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-              -- If InstanceDef set info to Instance-              let info' = case instanc of-                    InstanceDef _  -> makeInstance info-                    NotInstanceDef -> info-              -- There are sometimes two instances of the-              -- let-bound variable, one declaration and one-              -- definition. The first list element below is-              -- used to highlight the declared instance in the-              -- right way (see Issue 1618).-              return [ A.LetDeclaredVariable (A.mkBindName (setRange (getRange x') x))-                     , A.LetBind (LetRange $ getRange d) info' (A.mkBindName x) t e-                     ]--      -- irrefutable let binding, like  (x , y) = rhs-      NiceFunClause r PublicAccess ConcreteDef tc cc catchall d@(C.FunClause lhs@(C.LHS p [] [] NoEllipsis) (C.RHS rhs) NoWhere ca) -> do-        mp  <- setCurrentRange p $-                 (Right <$> parsePattern p)-                   `catchError`-                 (return . Left)-        case mp of-          Right p -> do-            rhs <- toAbstract rhs-            p   <- toAbstract p-            checkPatternLinearity p $ \ys ->-              typeError $ RepeatedVariablesInPattern ys-            bindVarsToBind-            p   <- toAbstract p-            return [ 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 p of-              Nothing -> throwError err-              Just x  -> toAbstract $ LetDef $ NiceMutual r tc cc YesPositivityCheck-                [ C.FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef 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 _ (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.RawAppP _ [])       = __IMPOSSIBLE__-              definedName C.AppP{}               = __IMPOSSIBLE__-              definedName C.OpAppP{}             = __IMPOSSIBLE__-              definedName C.EllipsisP{}          = Nothing -- Not impossible, see issue #3937--      -- You can't open public in a let-      NiceOpen r x dirs -> do-        whenJust (publicOpen dirs) $ \r -> setCurrentRange r $ warning UselessPublic-        m    <- toAbstract (OldModuleName x)-        adir <- openModule_ LetOpenModule x dirs-        let minfo = ModuleInfo-              { minfoRange  = r-              , minfoAsName = Nothing-              , minfoAsTo   = renamingRange dirs-              , minfoOpenShort = Nothing-              , minfoDirective = Just dirs-              }-        return [A.LetOpen minfo m adir]--      NiceModuleMacro r p x modapp open dir -> do-        whenJust (publicOpen dir) $ \ r -> setCurrentRange r $ warning UselessPublic-        -- Andreas, 2014-10-09, Issue 1299: module macros in lets need-        -- to be private-        checkModuleMacro LetApply LetOpenModule r (PrivateAccess Inserted) x modapp open dir--      _   -> notAValidLetBinding d-    where-        letToAbstract (C.Clause top catchall clhs@(C.LHS p [] [] NoEllipsis) (C.RHS rhs) NoWhere []) = do-{--            p    <- parseLHS top p-            localToAbstract (snd $ lhsArgs p) $ \args ->--}-            (x, args) <- do-              res <- setCurrentRange p $ parseLHS (C.QName top) p-              case res of-                C.LHSHead x args -> return (x, args)-                C.LHSProj{} -> genericError $ "copatterns not allowed in let bindings"-                C.LHSWith{} -> genericError $ "with-patterns not allowed in let bindings"--            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 DomainFree-            return (x, e)-        letToAbstract _ = notAValidLetBinding d--        -- Named patterns not allowed in let definitions-        lambda e (Arg info (Named Nothing (A.VarP x))) =-                return $ A.Lam i (A.mkDomainFree $ unnamedArg info $ A.mkBinder x) e-            where i = ExprRange (fuseRange x e)-        lambda e (Arg info (Named Nothing (A.WildP i))) =-            do  x <- freshNoName (getRange i)-                return $ A.Lam i' (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ x) e-            where i' = ExprRange (fuseRange i e)-        lambda _ _ = notAValidLetBinding d----UNUSED Liang-Ting Chen 2019-07-16---newtype Blind a = Blind { unBlind :: a }------instance ToAbstract (Blind a) (Blind a) where---  toAbstract = return--instance ToAbstract NiceDeclaration A.Declaration where--  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.-    caseMaybe (niceHasAbstract d) id (\ a -> localTC $ \ e -> e { envAbstractMode = aDefToMode a }) $-    case d of--  -- Axiom (actual postulate)-    C.Axiom r p a i rel x t -> do-      -- check that we do not postulate in --safe mode, unless it is a-      -- builtin module with safe postulates-      whenM ((return . Lens.getSafeMode =<< commandLineOptions) `and2M`-             (not <$> (Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath)))-            (warning $ SafeFlagPostulate x)-      -- check the postulate-      toAbstractNiceAxiom A.NoFunSig NotMacroDef d--    C.NiceGeneralize r p i tac x t -> do-      reportSLn "scope.decl" 10 $ "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 t -> do-      unless (p == PublicAccess) $ genericError "Record fields can not be private"-      -- Interaction points for record fields have already been introduced-      -- when checking the type of the record constructor.-      -- To avoid introducing interaction points (IP) twice, we turn-      -- all question marks to underscores.  (See issue 1138.)-      let maskIP (C.QuestionMark r _) = C.Underscore r Nothing-          maskIP e                     = e-      tac <- traverse (toAbstractCtx TopCtx) tac-      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 t' ]--  -- Primitive function-    PrimitiveFunction r p a x t -> do-      t' <- toAbstractCtx TopCtx t-      f  <- getConcreteFixity x-      y  <- freshAbstractQName f x-      bindName p PrimName x y-      return [ A.Primitive (mkDefInfo x f p a r) y t' ]--  -- Definitions (possibly mutual)-    NiceMutual r tc cc pc ds -> do-      ds' <- toAbstract ds-      -- We only termination check blocks that do not have a measure.-      return [ A.Mutual (MutualInfo tc cc pc r) ds' ]--    C.NiceRecSig r 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) x' ls' t' ]--    C.NiceDataSig r p a _pc _uc x ls t -> do-        reportSLn "scope.data.sig" 20 ("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-          bindName' p DataName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'-          return [ A.DataSig (mkDefInfo x f p a r) x' ls' t' ]--  -- Type signatures-    C.FunSig r p a i m rel _ _ x t ->-        toAbstractNiceAxiom A.FunSig m (C.Axiom r p a i rel x t)--  -- Function definitions-    C.FunDef r ds a i _ _ x cs -> do-        printLocals 10 $ "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__-        let delayed = NotDelayed-        -- (delayed, cs) <- translateCopatternClauses cs -- TODO-        f <- getConcreteFixity x-        return [ A.FunDef (mkDefInfoInstance x f PublicAccess a i NotMacroDef r) x' delayed cs ]--  -- Uncategorized function clauses-    C.NiceFunClause _ _ _ _ _ _ (C.FunClause lhs _ _ _) ->-      genericError $-        "Missing type signature for left hand side " ++ prettyShow lhs-    C.NiceFunClause{} -> __IMPOSSIBLE__--  -- Data definitions-    C.NiceDataDef r o a _ uc x pars cons -> do-        reportSLn "scope.data.def" 20 ("checking " ++ show o ++ " DataDef for " ++ prettyShow x)-        (p, ax) <- resolveName (C.QName x) >>= \case-          DefinedName p ax -> 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)-          _ -> genericError $ "Missing type signature for data definition " ++ prettyShow x-        ensureNoLetStms pars-        withLocalVars $ do-          gvars <- bindGeneralizablesIfInserted o ax-          -- Check for duplicate constructors-          do cs <- mapM conName cons-             unlessNull (duplicates cs) $ \ dups -> do-               let bad = filter (`elem` dups) cs-               setCurrentRange bad $-                 typeError $ DuplicateConstructors dups--          pars <- toAbstract pars-          let x' = anameName ax-          -- Create the module for the qualified constructors-          checkForModuleClash x -- disallow shadowing previously defined modules-          let m = mnameFromList $ qnameToList x'-          createModule (Just IsData) m-          bindModule p x m  -- make it a proper module-          cons <- toAbstract (map (ConstrDecl m a p) cons)-          printScope "data" 20 $ "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 ind eta cm pars fields -> do-      reportSLn "scope.rec.def" 20 ("checking " ++ show o ++ " RecDef for " ++ prettyShow x)-      (p, ax) <- resolveName (C.QName x) >>= \case-        DefinedName p ax -> 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)-        _ -> genericError $ "Missing type signature for record definition " ++ prettyShow 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   <- 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 $ mnameFromList [ last $ qnameToList x' ]-        printScope "rec" 15 "before record"-        createModule (Just IsRecord) m-        -- We scope check the fields a second time, as actual fields.-        afields <- withCurrentModule m $ do-          afields <- toAbstract fields-          printScope "rec" 15 "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-           unlessNull (duplicates fs) $ \ dups -> do-             let bad = filter (`elem` dups) fs-             setCurrentRange bad $-               typeError $ DuplicateFields dups-        bindModule p x m-        -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.-        cm' <- forM cm $ \ (c, _) -> bindRecordConstructorName c a p-        let inst = caseMaybe cm NotInstanceDef snd-        printScope "rec" 15 "record complete"-        f <- getConcreteFixity x-        let params = DataDefParams gvars pars-        return [ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' uc ind eta cm' params contel afields ]--    NiceModule r p a x@(C.QName name) tel ds -> do-      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checking NiceModule " ++ prettyShow x-        ]--      adecls <- traceCall (ScopeCheckDeclaration $ NiceModule r p a x tel []) $ do-        scopeCheckNiceModule r p name tel $ toAbstract ds--      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checked NiceModule " ++ prettyShow x-        ] ++ map (nest 2 . prettyA) adecls-      return adecls--    NiceModule _ _ _ m@C.Qual{} _ _ ->-      genericError $ "Local modules cannot have qualified names"--    NiceModuleMacro r p x modapp open dir -> do-      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checking NiceModuleMacro " ++ prettyShow x-        ]--      adecls <- checkModuleMacro Apply TopOpenModule r p x modapp open dir--      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checked NiceModuleMacro " ++ prettyShow x-        ] ++ map (nest 2 . prettyA) adecls-      return adecls--    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-      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 = traceCall (SetRange $ getRange 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 ""--      -- First scope check the imported module and return its name and-      -- interface. This is done with that module as the top-level module.-      -- This is quite subtle. We rely on the fact that when setting the-      -- top-level module and generating a fresh module name, the generated-      -- name will be exactly the same as the name generated when checking-      -- the imported module.-      (m, i) <- withCurrentModule noModuleName $ withTopLevelModule x $ do-        m <- toAbstract $ NewModuleQName x-        printScope "import" 10 "before import:"-        (m, i) <- scopeCheckImport m-        printScope "import" 10 $ "scope checked import: " ++ show i-        -- We don't want the top scope of the imported module (things happening-        -- before the module declaration)-        return (m, Map.delete noModuleName i)--      -- Merge the imported scopes with the current scopes-      modifyScopes $ \ ms -> Map.unionWith mergeScope (Map.delete m ms) i--      -- Bind the desired module name to the right abstract name.-      case as of-        Nothing -> bindQModule (PrivateAccess Inserted) x m-        Just y -> (unless . isNoName) (asName y) $-          bindModule (PrivateAccess Inserted) (asName y) m--      printScope "import" 10 "merged imported sig:"--      -- Open if specified, otherwise apply import directives-      let (name, theAsSymbol, theAsName) = case as of-            Just a | (not . isNoName) (asName a) -> (C.QName (asName a), asRange a, Just (asName a))-            _                                    -> (x,                  noRange,   Nothing)-      adir <- case open of-        DoOpen   -> do-          -- 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 -> modifyNamedScopeM m $ applyImportDirectiveM x dir-      let minfo = ModuleInfo-            { minfoRange     = r-            , minfoAsName    = theAsName-            , minfoAsTo      = getRange (theAsSymbol, renamingRange dir)-            , minfoOpenShort = Just open-            , minfoDirective = Just dir-            }-      return [ A.Import minfo m 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-      return [ A.Mutual mi [A.UnquoteDecl mi [ mkDefInfoInstance x fx p a i NotMacroDef r | (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-      return [ A.UnquoteDef [ mkDefInfo x fx PublicAccess a r | (fx, x) <- zip fxs xs ] ys e ]--    NicePatternSyn r a n as p -> do-      reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ prettyShow n-      (as, p) <- withLocalVars $ do-         p  <- toAbstract =<< parsePatternSyn p-         checkPatternLinearity p $ \ys ->-           typeError $ RepeatedVariablesInPattern ys-         bindVarsToBind-         let err = "Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead."-         p <- noDotorEqPattern err p-         as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as-         unlessNull (patternVars p List.\\ map unArg as) $ \ xs -> do-           typeError . GenericDocError =<< do-             "Unbound variables in pattern synonym: " <+>-               sep (map prettyA 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 as p]   -- only for highlighting, so use unexpanded version-      where unVarName (VarName a _) = return a-            unVarName _ = typeError $ UnusedVariableInPatternSynonym--    where-      -- checking postulate or type sig. without checking safe flag-      toAbstractNiceAxiom funSig isMacro (C.Axiom r p a i info x t) = do-        t' <- toAbstractCtx TopCtx t-        f  <- getConcreteFixity x-        mp <- getConcretePolarity x-        y  <- freshAbstractQName f x-        let kind | isMacro == MacroDef = MacroName-                 | otherwise           = OtherDefName  -- could be a type signature-        bindName p kind x y-        return [ A.Axiom funSig (mkDefInfoInstance x f p a i isMacro r) info mp y t' ]-      toAbstractNiceAxiom _ _ _ = __IMPOSSIBLE__--unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr)-unGeneralized (A.Generalized s t) = (s, t)-unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e-unGeneralized t = (mempty, t)--collectGeneralizables :: ScopeM a -> ScopeM (Set I.QName, a)-collectGeneralizables m = 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 I.QName -> ScopeM (Map I.QName I.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 I.QName I.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 A.GeneralizeTelescope where-  toAbstract (GenTel tel) =-    uncurry A.GeneralizeTel <$> collectAndBindGeneralizables (toAbstract tel)--instance ToAbstract GenTelAndType (A.GeneralizeTelescope, A.Expr) where-  toAbstract (GenTelAndType tel t) = do-    (binds, (tel, t)) <- collectAndBindGeneralizables $-                          (,) <$> toAbstract tel <*> toAbstract t-    return (A.GeneralizeTel binds tel, t)---- | 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: " ++ show x-      , "  current module: " ++ show m-      ]-    unless (A.qnameModule x == m) $-      genericError $ "Definition in different module than its type signature"---- | 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)---- | 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)--lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]-lookupModuleInCurrentModule x =-  fromMaybe [] . Map.lookup x . nsModules . thingsInScope [PublicNS, PrivateNS] <$> getCurrentScope--data ConstrDecl = ConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration--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 -> PrivateAccess Inserted-           _           -> p-    p'' = case a of-            AbstractDef -> PrivateAccess Inserted-            _           -> 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 -> IsAbstract -> Access -> ScopeM A.QName-bindRecordConstructorName x a p = do-  y <- freshAbstractQName' x-  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 -> PrivateAccess Inserted-           _           -> p--instance ToAbstract ConstrDecl A.Declaration where-  toAbstract (ConstrDecl m a p d) = do-    case d of-      C.Axiom r p1 a1 i info x t -> do -- rel==Relevant-        -- unless (p1 == p) __IMPOSSIBLE__  -- This invariant is currently violated by test/Succeed/Issue282.agda-        unless (a1 == a) __IMPOSSIBLE__-        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" 15 "bound constructor"-        return $ A.Axiom NoFunSig (mkDefInfoInstance x f p a i NotMacroDef r)-                         info Nothing y t'-      _ -> errorNotConstrDecl d--errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a-errorNotConstrDecl d = typeError . GenericDocError $-        "Illegal declaration in data type definition " P.$$-        P.nest 2 (P.vcat $ map pretty (notSoNiceDeclarations d))--instance ToAbstract C.Pragma [A.Pragma] where-  toAbstract (C.ImpossiblePragma _) = impossibleTest-  toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]-  toAbstract (C.RewritePragma _ _ []) = [] <$ warning EmptyRewritePragma-  toAbstract (C.RewritePragma _ r xs) = singleton . A.RewritePragma r . concat <$> do-   forM xs $ \ x -> do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x          -> return [ x ]-      A.Proj _ p | Just x <- getUnambiguous p -> return [ x ]-      A.Proj _ x       -> genericError $ "REWRITE used on ambiguous name " ++ prettyShow x-      A.Con c | Just x <- getUnambiguous c -> return [ x ]-      A.Con x          -> genericError $ "REWRITE used on ambiguous name " ++ prettyShow x-      A.Var x          -> genericError $ "REWRITE used on parameter " ++ prettyShow x ++ " instead of on a defined symbol"-      _       -> __IMPOSSIBLE__-  toAbstract (C.ForeignPragma _ rb s) = [] <$ addForeignCode (rangedThing rb) s-  toAbstract (C.CompilePragma _ rb x s) = do-    let b = rangedThing rb-    me <- toAbstract $ MaybeOldQName $ OldQName x Nothing-    case me of-      Nothing -> [] <$ notInScopeWarning x-      Just e  -> do-        let err what = genericError $ "Cannot COMPILE " ++ what ++ " " ++ prettyShow x-        y <- case e of-          A.Def x             -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x          -> err "ambiguous projection"-          A.Con c | Just x <- getUnambiguous c -> return x-          A.Con x             -> err "ambiguous constructor"-          A.PatternSyn{}      -> err "pattern synonym"-          A.Var{}             -> err "local variable"-          _                   -> __IMPOSSIBLE__-        return [ A.CompilePragma rb y s ]--  toAbstract (C.StaticPragma _ x) = do-      e <- toAbstract $ OldQName x Nothing-      y <- case e of-          A.Def  x -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x -> genericError $-            "STATIC used on ambiguous name " ++ prettyShow x-          _        -> genericError "Target of STATIC pragma should be a function"-      return [ A.StaticPragma y ]-  toAbstract (C.InjectivePragma _ x) = do-      e <- toAbstract $ OldQName x Nothing-      y <- case e of-          A.Def  x -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x -> genericError $-            "INJECTIVE used on ambiguous name " ++ prettyShow x-          _        -> genericError "Target of INJECTIVE pragma should be a defined symbol"-      return [ A.InjectivePragma y ]-  toAbstract (C.InlinePragma _ b x) = do-      e <- toAbstract $ OldQName x Nothing-      let sINLINE = if b then "INLINE" else "NOINLINE"-      y <- case e of-          A.Def  x -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x -> genericError $-            sINLINE ++ " used on ambiguous name " ++ prettyShow x-          _        -> genericError $ "Target of " ++ sINLINE ++ " pragma should be a function"-      return [ A.InlinePragma b y ]-  toAbstract (C.BuiltinPragma _ rb q)-    | isUntypedBuiltin b = do-        bindUntypedBuiltin b =<< toAbstract (ResolveQName q)-        return []-    | otherwise = do-        -- Andreas, 2015-02-14-        -- Some builtins cannot be given a valid Agda type,-        -- thus, they do not come with accompanying postulate or definition.-        if b `elem` builtinsNoDef then do-          case q 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 q) $ do-                genericWarning $ P.text $-                   "BUILTIN " ++ b ++ " declares an identifier " ++-                   "(no longer expects an already defined identifier)"-                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 y ]-            _ -> genericError $-              "Pragma BUILTIN " ++ b ++ ": expected unqualified identifier, " ++-              "but found " ++ prettyShow q-        else do-          q <- toAbstract $ ResolveQName q-          return [ A.BuiltinPragma rb q ]-    where b = rangedThing rb-  toAbstract (C.EtaPragma _ x) = do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x -> return [ A.EtaPragma x ]-      _       -> do-       e <- showA e-       genericError $ "Pragma ETA: expected identifier, " ++-         "but found expression " ++ e-  toAbstract (C.DisplayPragma _ lhs rhs) = withLocalVars $ do-    let err = genericError "DISPLAY pragma left-hand side must have form 'f e1 .. en'"-        getHead (C.IdentP x)          = return x-        getHead (C.RawAppP _ (p : _)) = getHead p-        getHead _                     = err--    top <- getHead lhs--    (isPatSyn, hd) <- do-      qx <- resolveName' allKindsOfNames Nothing top-      case qx of-        VarName x' _                -> return . (False,) $ A.qnameFromList [x']-        DefinedName _ d             -> return . (False,) $ anameName d-        FieldName     (d :| [])     -> return . (False,) $ anameName d-        FieldName ds                -> genericError $ "Ambiguous projection " ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)-        ConstructorName (d :| [])   -> return . (False,) $ anameName d-        ConstructorName ds          -> genericError $ "Ambiguous constructor " ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)-        UnknownName                 -> notInScopeError top-        PatternSynResName (d :| []) -> return . (True,) $ anameName d-        PatternSynResName ds        -> genericError $ "Ambiguous pattern synonym" ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)--    lhs <- toAbstract $ LeftHandSide top lhs NoEllipsis-    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-      let mkP | isPatSyn  = A.PatternSynP (PatRange $ getRange lhs) (unambiguous hd)-              | otherwise = A.DefP (PatRange $ getRange lhs) (unambiguous hd)-      p <- expandPatternSynonyms $ mkP 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 <- toAbstract rhs-    return [A.DisplayPragma hd ps rhs]--  toAbstract (C.WarningOnUsage _ oqn str) = do-    qn <- toAbstract $ OldName oqn-    stLocalUserWarnings `modifyTCLens` Map.insert qn str-    pure []--  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__--instance ToAbstract C.Clause A.Clause where-  toAbstract (C.Clause top catchall lhs@(C.LHS p eqs with ell) 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 ell-    printLocals 10 "after lhs:"-    vars1 <- getLocalVars-    eqs <- mapM (toAbstractCtx TopCtx) eqs-    vars2 <- getLocalVars-    let vars = dropEnd (length vars1) vars2 ++ vars0-    let wcs' = for wcs $ \ c -> setLocalVars vars $> c-    let (whname, whds) = case wh of-          NoWhere        -> (Nothing, [])-          -- Andreas, 2016-07-17 issues #2081 and #2101-          -- where-declarations are automatically private.-          -- This allows their type signature to be checked InAbstractMode.-          AnyWhere ds    -> (Nothing, [C.Private noRange Inserted ds])-          -- Named where-modules do not default to private.-          SomeWhere m a ds -> (Just (m, a), ds)--    let isTerminationPragma :: C.Declaration -> Bool-        isTerminationPragma (C.Private _ _ ds) = any isTerminationPragma ds-        isTerminationPragma (C.Pragma (TerminationCheckPragma _ _)) = True-        isTerminationPragma _                                       = False--    if not (null eqs)-      then do-        rhs <- toAbstract =<< toAbstractCtx TopCtx (RightHandSide eqs with wcs' rhs whname whds)-        return $ A.Clause lhs' [] rhs A.noWhereDecls catchall-      else do-        -- ASR (16 November 2015) Issue 1137: We ban termination-        -- pragmas inside `where` clause.-        when (any isTerminationPragma whds) $-             genericError "Termination pragmas are not allowed inside where clauses"--        -- the right hand side is checked with the module of the local definitions opened-        (rhs, ds) <- whereToAbstract (getRange wh) whname whds $-                      toAbstractCtx TopCtx (RightHandSide eqs with wcs' rhs Nothing [])-        rhs <- toAbstract rhs-                 -- #2897: we need to restrict named where modules in refined contexts,-                 --        so remember whether it was named here-        return $ A.Clause lhs' [] rhs ds catchall--whereToAbstract-  :: Range                            -- ^ The range of the @where@-block.-  -> Maybe (C.Name, Access)           -- ^ The name of the @where@ module (if any).-  -> [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.-whereToAbstract _ whname []   inner = (, A.noWhereDecls) <$> inner-whereToAbstract r whname whds inner = do-  -- 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, PrivateAccess Inserted)-           -- unnamed where's are private-  let tel = []-  old <- getCurrentModule-  am  <- toAbstract (NewModuleName m)-  (scope, ds) <- scopeCheckModule r (C.QName m) am tel $ toAbstract 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 noRange }-  return (x, A.WhereDecls (am <$ whname) ds)--data RightHandSide = RightHandSide-  { _rhsRewriteEqn :: [RewriteEqn' () A.Pattern A.Expr]-    -- ^ @rewrite e | with p <- e@ (many)-  , _rhsWithExpr   :: [WithHiding C.WithExpr]-    -- ^ @with e@ (many)-  , _rhsSubclauses :: [ScopeM C.Clause]-    -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)-  , _rhs           :: C.RHS-  , _rhsWhereName  :: Maybe (C.Name, Access)-    -- ^ The name of the @where@ module (if any).-  , _rhsWhereDecls :: [C.Declaration]-    -- ^ The contents of the @where@ module.-  }--data AbstractRHS-  = AbsurdRHS'-  | WithRHS' [WithHiding A.Expr] [ScopeM C.Clause]-    -- ^ The with clauses haven't been translated yet-  | RHS' A.Expr C.Expr-  | RewriteRHS' [RewriteEqn' () 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.Pattern A.Expr) A.RewriteEqn where-  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--instance ToAbstract C.RewriteEqn (RewriteEqn' () A.Pattern A.Expr) where-  toAbstract = \case-    Rewrite es   -> Rewrite <$> mapM toAbstract es-    Invert _ pes -> Invert () <$> do-      let (ps, es) = unzip pes-      -- first check the expressions: the patterns may shadow some of the variables-      -- mentioned in them!-      es <- toAbstract es-      -- then parse the patterns and go through the motions of converting them,-      -- checking them for linearity, binding the variable introduced in them-      -- and finally producing an abstract pattern.-      ps <- forM ps $ \ p -> do-        p <- parsePattern p-        p <- toAbstract p-        checkPatternLinearity p (typeError . RepeatedVariablesInPattern)-        bindVarsToBind-        toAbstract p-      pure $ zip ps es--instance ToAbstract AbstractRHS A.RHS where-  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 AbstractRHS where-  toAbstract (RightHandSide eqs@(_:_) es cs rhs whname wh) = do-    (rhs, ds) <- whereToAbstract (getRange wh) whname wh $-                  toAbstract (RightHandSide [] es cs rhs Nothing [])-    return $ RewriteRHS' eqs rhs ds-  toAbstract (RightHandSide [] [] (_ : _) _ _ _)        = __IMPOSSIBLE__-  toAbstract (RightHandSide [] (_ : _) _ (C.RHS _) _ _) = typeError $ BothWithAndRHS-  toAbstract (RightHandSide [] [] [] rhs _ [])          = toAbstract rhs-  toAbstract (RightHandSide [] es cs C.AbsurdRHS _ [])  = do-    es <- toAbstractCtx TopCtx es-    return $ WithRHS' es cs-  -- TODO: some of these might be possible-  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS _ (_ : _)) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] [] [] (C.RHS _) _ (_ : _))       = __IMPOSSIBLE__-  toAbstract (RightHandSide [] [] [] C.AbsurdRHS _ (_ : _))     = __IMPOSSIBLE__--instance ToAbstract C.RHS AbstractRHS where-    toAbstract C.AbsurdRHS = return $ AbsurdRHS'-    toAbstract (C.RHS e)   = RHS' <$> toAbstract e <*> pure e--data LeftHandSide = LeftHandSide C.QName C.Pattern ExpandedEllipsis--instance ToAbstract LeftHandSide A.LHS where-    toAbstract (LeftHandSide top lhs ell) =-      traceCall (ScopeCheckLHS top lhs) $ do-        lhscore <- parseLHS top lhs-        reportSLn "scope.lhs" 5 $ "parsed lhs: " ++ show lhscore-        printLocals 10 "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 lhscore-        bindVarsToBind-        reportSLn "scope.lhs" 5 $ "parsed lhs patterns: " ++ show lhscore-        printLocals 10 "checked pattern:"-        -- scope check dot patterns-        lhscore <- toAbstract lhscore-        reportSLn "scope.lhs" 5 $ "parsed lhs dot patterns: " ++ show lhscore-        printLocals 10 "checked dots:"-        return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore---- Merges adjacent EqualP patterns into one: typecheking expects only one pattern for each domain in the telescope.-mergeEqualPs :: [NamedArg (Pattern' e)] -> [NamedArg (Pattern' e)]-mergeEqualPs = go Nothing-  where-    go acc (Arg i (Named n (A.EqualP r es)) : ps) = go (fmap (fmap (++es)) acc `mplus` Just ((i,n,r),es)) ps-    go Nothing [] = []-    go Nothing (p : ps) = p : go Nothing ps-    go (Just ((i,n,r),es)) ps = Arg i (Named n (A.EqualP r es)) :-      case ps of-        (p : ps) -> p : go Nothing ps-        []     -> []---- does not check pattern linearity-instance ToAbstract C.LHSCore (A.LHSCore' C.Expr) where-    toAbstract (C.LHSHead x ps) = do-        x <- withLocalVars $ do-          setLocalVars []-          toAbstract (OldName x)-        A.LHSHead x . mergeEqualPs <$> toAbstract ps-    toAbstract (C.LHSProj d ps1 l ps2) = do-        unless (null ps1) $ typeError $ GenericDocError $-          "Ill-formed projection pattern" P.<+> P.pretty (foldl C.AppP (C.IdentP d) ps1)-        qx <- resolveName d-        ds <- case qx of-                FieldName ds -> return $ fmap anameName ds-                UnknownName -> notInScopeError d-                _           -> genericError $-                  "head of copattern needs to be a field identifier, but "-                  ++ prettyShow d ++ " isn't one"-        A.LHSProj (AmbQ ds) <$> toAbstract l <*> (mergeEqualPs <$> toAbstract ps2)-    toAbstract (C.LHSWith core wps ps) = do-      liftA3 A.LHSWith-        (toAbstract core)-        (toAbstract wps)-        (toAbstract ps)--instance ToAbstract c a => ToAbstract (WithHiding c) (WithHiding a) where-  toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a--instance ToAbstract c a => ToAbstract (Arg c) (Arg a) where-    toAbstract (Arg info e) =-        Arg info <$> toAbstractHiding info e--instance ToAbstract c a => ToAbstract (Named name c) (Named name a) where-    toAbstract (Named n e) = Named n <$> toAbstract e--{- 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) (A.LHSCore' A.Expr) where-    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) (A.Pattern' A.Expr) where-  toAbstract = traverse $ insideDotPattern . toAbstractCtx DotPatternCtx  -- Issue #3033--resolvePatternIdentifier ::-  Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)-resolvePatternIdentifier r x ns = do-  reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ show x ++ " at source position " ++ show r-  px <- toAbstract (PatName x ns)-  case px of-    VarPatName y         -> do-      reportSLn "scope.pat" 60 $ "  resolved to VarPatName " ++ show y ++ " with range " ++ show (getRange y)-      return $ VarP $ A.mkBindName y-    ConPatName ds        -> return $ ConP (ConPatInfo ConOCon (PatRange r) ConPatEager)-                                          (AmbQ $ fmap anameName ds) []-    PatternSynPatName ds -> return $ PatternSynP (PatRange r)-                                                 (AmbQ $ fmap anameName ds) []---- | 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.-  -> NAPs C.Expr          -- ^ Arguments of application.-  -> ScopeM (A.Pattern' C.Expr)-applyAPattern p0 p ps = do-  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--instance ToAbstract C.Pattern (A.Pattern' C.Expr) where--    toAbstract (C.IdentP x) =-      resolvePatternIdentifier (getRange x) x Nothing--    toAbstract (AppP (QuoteP _) p)-      | IdentP x <- namedArg p,-        visible p = do-      e <- toAbstract (OldQName x Nothing)-      let quoted (A.Def x) = return x-          quoted (A.Macro x) = return x-          quoted (A.Proj _ p)-            | Just x <- getUnambiguous p = return x-            | otherwise                  = genericError $ "quote: Ambigous name: " ++ prettyShow (unAmbQ p)-          quoted (A.Con c)-            | Just x <- getUnambiguous c = return x-            | otherwise                  = genericError $ "quote: Ambigous name: " ++ prettyShow (unAmbQ c)-          quoted (A.ScopedExpr _ e) = quoted e-          quoted _                  = genericError $ "quote: not a defined name"-      A.LitP . LitQName (getRange x) <$> quoted e--    toAbstract (QuoteP r) =-      genericError "quote must be applied to an identifier"--    toAbstract p0@(AppP p q) = do-        reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p-        p <- distributeDots p-        reportSLn "scope.pat" 50 $ "distributeDots after  = " ++ show p-        (p', q') <- toAbstract (p, q)-        applyAPattern p0 p' [q']--        where-            distributeDots :: C.Pattern -> ScopeM C.Pattern-            distributeDots p@(C.DotP r e) = distributeDotsExpr r e-            distributeDots p = return p--            distributeDotsExpr :: Range -> C.Expr -> ScopeM C.Pattern-            distributeDotsExpr r e = parseRawApp e >>= \case-              C.App r e a     ->-                AppP <$> distributeDotsExpr r e-                     <*> (traverse . traverse) (distributeDotsExpr r) a-              OpApp r q ns as ->-                case (traverse . traverse . traverse) fromNoPlaceholder as of-                  Just as -> OpAppP r q ns <$>-                    (traverse . traverse . traverse) (distributeDotsExpr r) as-                  Nothing -> return $ C.DotP r e-              Paren r e -> ParenP r <$> distributeDotsExpr r e-              _ -> return $ C.DotP 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--    toAbstract p0@(OpAppP r op ns ps) = do-        reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0-        p  <- resolvePatternIdentifier (getRange op) op (Just ns)-        ps <- toAbstract ps-        applyAPattern p0 p ps--    -- Removed when parsing-    toAbstract (HiddenP _ _)   = __IMPOSSIBLE__-    toAbstract (InstanceP _ _) = __IMPOSSIBLE__-    toAbstract (RawAppP _ _)   = __IMPOSSIBLE__-    toAbstract (EllipsisP _)   = __IMPOSSIBLE__--    toAbstract p@(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 "_"-    toAbstract (C.ParenP _ p)   = toAbstract p-    toAbstract (C.LitP l)       = return $ A.LitP l-    toAbstract p0@(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)-        x <- bindPatternVariable x-        p <- toAbstract p-        return $ A.AsP (PatRange r) (A.mkBindName x) p-    toAbstract p0@(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.-    toAbstract p0@(C.DotP 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--    toAbstract p0@(C.AbsurdP r)    = return $ A.AbsurdP (PatRange r)-    toAbstract (C.RecP r fs)       = A.RecP (PatRange r) <$> mapM (traverse toAbstract) fs-    toAbstract (C.WithP r p)       = A.WithP (PatRange r) <$> toAbstract p---- | 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 -> Set A.Name ->-                   [NamedArg (MaybePlaceholder (OpApp C.Expr))] ->-                   ScopeM A.Expr-toAbstractOpApp op ns es = do-    -- Replace placeholders with bound variables.-    (binders, es) <- replacePlaceholders es-    -- Get the notation for the operator.-    nota <- getNotation op ns-    let parts = notation nota-    -- We can throw away the @BindingHoles@, since binders-    -- have been preprocessed into @OpApp C.Expr@.-    let nonBindingParts = filter (not . isBindingHole) parts-    -- 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 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 is filled with an expression in @InsideOperandCtx@.-    inside f [x]          es    = right f x es-    inside f (IdPart _ : xs) es = inside f xs es-    inside f (_  : xs) (e : es) = do-        e  <- toAbsOpArg InsideOperandCtx e-        es <- inside f xs es-        return (e : es)-    inside _ (_ : _) [] = __IMPOSSIBLE__-    inside _ []         _  = __IMPOSSIBLE__--    -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.-    right _ (IdPart _)  [] = return []-    right f _          [e] = do-        let pref = inferParenPref e-        e <- toAbsOpArg (RightOperandCtx f pref) e-        return [e]-    right _ _     _  = __IMPOSSIBLE__--    replacePlaceholders ::-      [NamedArg (MaybePlaceholder (OpApp 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.mkBinder_ x) : ls-               , set (Left (Var x)) a : ns-               )-      where-      set :: a -> NamedArg b -> NamedArg a-      set x arg = fmap (fmap (const x)) arg---{---------------------------------------------------------------------------    Things we parse but are not part of the Agda file syntax- --------------------------------------------------------------------------}---- | Content of interaction hole.--instance ToAbstract C.HoleContent A.HoleContent where++{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,+    figuring out infix operator precedences and tidying up definitions.+-}+module Agda.Syntax.Translation.ConcreteToAbstract+    ( ToAbstract(..), localToAbstract+    , concreteToAbstract_+    , concreteToAbstract+    , NewModuleQName(..)+    , TopLevel(..)+    , TopLevelInfo(..)+    , topLevelModuleName+    , AbstractRHS+    , NewModuleName, OldModuleName+    , NewName, OldQName+    , PatName, APatName+    , importPrimitives+    ) where++import Prelude hiding ( null )++import Control.Applicative hiding ( empty )+import Control.Monad.Except+import Control.Monad.Reader++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 Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid (First(..))+import Data.Void++import Agda.Syntax.Concrete as C hiding (topLevelModuleName)+import Agda.Syntax.Concrete.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 )+import Agda.Syntax.Abstract.Pretty+import qualified Agda.Syntax.Internal as I+import Agda.Syntax.Position+import Agda.Syntax.Literal+import Agda.Syntax.Common+import Agda.Syntax.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.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)+import Agda.TypeChecking.Monad.State+import Agda.TypeChecking.Monad.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.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.CallStack ( HasCallStack, withCurrentCallStack )+import Agda.Utils.Char+import Agda.Utils.Either+import Agda.Utils.FileName+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 qualified Agda.Utils.Pretty as P+import Agda.Utils.Pretty (render, Pretty, pretty, prettyShow)+import Agda.Utils.Singleton+import Agda.Utils.Tuple++import Agda.Utils.Impossible+import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)++{--------------------------------------------------------------------------+    Exceptions+ --------------------------------------------------------------------------}++notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a+notAnExpression = locatedTypeError NotAnExpression++nothingAppliedToHiddenArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a+nothingAppliedToHiddenArg = locatedTypeError NothingAppliedToHiddenArg++nothingAppliedToInstanceArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a+nothingAppliedToInstanceArg = locatedTypeError NothingAppliedToInstanceArg++notAValidLetBinding :: (HasCallStack, MonadTCError m) => C.NiceDeclaration -> m a+notAValidLetBinding = locatedTypeError NotAValidLetBinding++{--------------------------------------------------------------------------+    Helpers+ --------------------------------------------------------------------------}+--UNUSED Liang-Ting Chen 2019-07-16+--annotateDecl :: ScopeM A.Declaration -> ScopeM A.Declaration+--annotateDecl m = annotateDecls $ (:[]) <$> m++annotateDecls :: ScopeM [A.Declaration] -> ScopeM A.Declaration+annotateDecls m = do+  ds <- m+  s  <- getScope+  return $ ScopedDecl s ds++annotateExpr :: ScopeM A.Expr -> ScopeM A.Expr+annotateExpr m = do+  e <- m+  s <- getScope+  return $ ScopedExpr s e++-- | Make sure that there are no dot patterns (called on pattern synonyms).+noDotorEqPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)+noDotorEqPattern err = dot+  where+    dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)+    dot = \case+      A.VarP x               -> pure $ A.VarP x+      A.ConP i c args        -> A.ConP i c <$> (traverse $ traverse $ traverse dot) args+      A.ProjP i o d          -> pure $ A.ProjP i o d+      A.WildP i              -> pure $ A.WildP i+      A.AsP i x p            -> A.AsP i x <$> dot p+      A.DotP{}               -> genericError err+      A.EqualP{}             -> genericError err   -- Andrea: so we also disallow = patterns, reasonable?+      A.AbsurdP i            -> pure $ A.AbsurdP i+      A.LitP i l             -> pure $ A.LitP i l+      A.DefP i f args        -> A.DefP i f <$> (traverse $ traverse $ traverse dot) args+      A.PatternSynP i c args -> A.PatternSynP i c <$> (traverse $ traverse $ traverse dot) args+      A.RecP i fs            -> A.RecP i <$> (traverse $ traverse dot) fs+      A.WithP i p            -> A.WithP i <$> dot p+      A.AnnP i a p           -> genericError err   -- TODO: should this be allowed?+--UNUSED Liang-Ting Chen 2019-07-16+---- | Make sure that there are no dot patterns (WAS: called on pattern synonyms).+--noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)+--noDotPattern err = traverse $ const $ genericError err++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+      dummy <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+      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 d)+      traceCall (SetRange r) $ case d of++        C.NiceField r pr ab inst tac x a -> do+          fx  <- getConcreteFixity x+          let bv = unnamed (C.mkBinder $ (C.mkBoundName x fx) { bnameTactic = tac }) <$ a+          toAbstract $ C.TBind r (singleton bv) (unArg a)++        -- 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 x modapp open dir -> do+          mkLet $ C.NiceModuleMacro r p 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++checkModuleApplication+  :: C.ModuleApplication+  -> ModuleName+  -> C.Name+  -> C.ImportDirective+  -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)++checkModuleApplication (C.SectionApp _ tel e) 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+    -- Check that expression @e@ is of the form @m args@.+    (m, args) <- parseModuleApplication e+    -- 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" 20 "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" 20 "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+      -> ModuleName+      -> A.ModuleApplication+      -> ScopeCopyInfo+      -> A.ImportDirective+      -> a)+  -> OpenKind+  -> Range+  -> Access+  -> C.Name+  -> C.ModuleApplication+  -> OpenShortHand+  -> C.ImportDirective+  -> ScopeM a+checkModuleMacro apply kind r p 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" 20 "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" 20 "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" 20 "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" 20 $ show open+    reportSDoc "scope.decl" 90 $ "after open   : m0 =" <+> prettyA m0++    stripNoNames+    printScope "mod.inst" 10 $ "after stripping"+    reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0++    let m      = m0 `withRangesOf` singleton x+        adecl  = apply info 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   dir = return dir+notPublicWithoutOpen DontOpen dir = do+  whenJust (publicOpen dir) $ \ r ->+    setCurrentRange r $ warning UselessPublic+  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+  reportSDoc "scope.decl" 70 $ do+    cm <- getCurrentModule+    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`+  whenJust (publicOpen dir) $ \ r -> do+    whenM ((A.noModuleName ==) <$> getCurrentModule) $ do+      setCurrentRange r $ warning UselessPublic++  m <- caseMaybe mam (toAbstract (OldModuleName x)) return+  printScope "open" 20 $ "opening " ++ prettyShow x+  adir <- openModule TopOpenModule (Just m) x dir+  printScope "open" 20 $ "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 (LitChar c)+  | isSurrogateCodePoint c = genericNonFatalError $ P.text $ "Invalid character literal " ++ show c +++                                                             " (surrogate code points are not supported)"+checkLiteral _ = 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 = fst <$> localToAbstract' x ret++-- | 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 (Set 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++newtype OldName a = OldName a++-- | Wrapper to resolve a name to a 'ResolvedName' (rather than an 'A.Expr').+data ResolveQName = ResolveQName C.QName++data PatName      = PatName C.QName (Maybe (Set A.Name))+  -- ^ If a set is given, then the first name must correspond to one+  -- of the names in the set.++instance ToAbstract (NewName C.Name) 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" 10 $ "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+        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 -> do+            typeError . GenericDocError =<<+              text "Cannot use generalized variable from let-opened module:" <+> prettyTCM (anameName d)+          _ -> return ()+        -- 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          -> 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 storeDiamsbiguatedName.+      raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM ()+      raiseWarningsOnUsageIfUnambiguous = \case+        x :| [] -> raiseWarningsOnUsage x+        _       -> return ()+++instance ToAbstract ResolveQName where+  type AbsOfCon ResolveQName = ResolvedName+  toAbstract (ResolveQName x) = resolveName x >>= \case+    UnknownName -> notInScopeError x+    q -> return q++data APatName = VarPatName A.Name+              | ConPatName (NonEmpty AbstractName)+              | PatternSynPatName (NonEmpty AbstractName)++instance ToAbstract PatName where+  type AbsOfCon PatName = APatName+  toAbstract (PatName x ns) = do+    reportSLn "scope.pat" 10 $ "checking pattern name: " ++ prettyShow x+    rx <- resolveName' (someKindsOfNames [ConName, CoConName, PatternSynName]) 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" 20 $ "resolved as " ++ prettyShow rx+    case (rx, x) of+      (VarName y _,       C.QName x)                           -> bindPatVar x+      (FieldName d,       C.QName x)                           -> bindPatVar x+      (DefinedName _ d _, C.QName x) | isDefName (anameKind d) -> bindPatVar x+      (UnknownName,       C.QName x)                           -> bindPatVar x+      (ConstructorName _ ds, _)                                -> patCon ds+      (PatternSynResName d, _)                                 -> patSyn d+      _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x+    where+      bindPatVar = VarPatName <.> bindPatternVariable+      patCon ds = do+        reportSLn "scope.pat" 10 $ "it was a con: " ++ prettyShow (fmap anameName ds)+        return $ ConPatName ds+      patSyn ds = do+        reportSLn "scope.pat" 10 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds)+        return $ PatternSynPatName ds++-- | Translate and possibly bind a pattern variable+--   (which could have been bound before due to non-linearity).+bindPatternVariable :: C.Name -> ScopeM A.Name+bindPatternVariable x = do+  y <- (AssocList.lookup x <$> getVarsToBind) >>= \case+    Just (LocalVar y _ _) -> do+      reportSLn "scope.pat" 10 $ "it was a old var: " ++ prettyShow x+      return $ setRange (getRange x) y+    Nothing -> do+      reportSLn "scope.pat" 10 $ "it was a new var: " ++ prettyShow x+      freshAbstractName_ x+  addVarToBind x $ LocalVar y PatternBound []+  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+    rx <- resolveName (toQName x)+    case rx of+      DefinedName _ d NoSuffix -> return $ anameName d+      DefinedName _ d Suffix{} -> notInScopeError (toQName x)+      -- We can get the cases below for DISPLAY pragmas+      ConstructorName _ ds -> return $ anameName (NonEmpty.head ds)   -- We'll throw out this one, so it doesn't matter which one we pick+      FieldName ds         -> return $ anameName (NonEmpty.head ds)+      PatternSynResName ds -> return $ anameName (NonEmpty.head ds)+      VarName x _          -> genericError $ "Not a defined name: " ++ prettyShow x+      UnknownName          -> notInScopeError (toQName x)++-- | Resolve a non-local name and return its possibly ambiguous abstract name.+toAbstractExistingName :: ToQName a => a -> ScopeM (List1 AbstractName)+toAbstractExistingName x = resolveName (toQName x) >>= \case+    DefinedName _ d NoSuffix -> return $ singleton d+    DefinedName _ d Suffix{} -> notInScopeError (toQName x)+    ConstructorName _ ds     -> return ds+    FieldName ds             -> return ds+    PatternSynResName ds     -> return ds+    VarName x _              -> genericError $ "Not a defined name: " ++ prettyShow x+    UnknownName              -> notInScopeError (toQName x)++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+  unless (null ms) $ do+    reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ prettyShow ms+    reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms+    setCurrentRange x $+      typeError $ ShadowedModule x $+                map ((`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+--UNUSED Liang-Ting 2019-07-16+---- | By default, arguments are @Relevant@.+--mkArg :: C.Expr -> Arg C.Expr+--mkArg e = mkArg' defaultArgInfo 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 _ e+        | Nothing <- mr -> toAbstractDotHiding (Just Irrelevant) mh prec e++      C.DoubleDot _ e+        | Nothing <- mr -> toAbstractDotHiding (Just NonStrict) 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 erased cs = do+  whenM isInsideDotPattern $+    genericError "Extended lambdas are not allowed in dot patterns"++  -- Find an unused name for the extended lambda definition.+  cname <- freshConcreteName r 0 extendedLambdaName+  name  <- freshAbstractName_ cname+  a <- asksTC (^. lensIsAbstract)+  reportSDoc "scope.extendedLambda" 10 $ 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 (PrivateAccess Inserted) 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 $ 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' NotDelayed cs] -> do+      setScope si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...+      return $+        A.ExtendedLam (ExprRange r) di erased qname' $+        List1.fromList cs+    _ -> __IMPOSSIBLE__++-- | Raise an error if argument is a C.Dot with Hiding info.++rejectPostfixProjectionWithHiding :: NamedArg C.Expr -> ScopeM ()+rejectPostfixProjectionWithHiding arg =+  case namedArg arg of+    C.Dot{} | notVisible arg -> setCurrentRange arg $ genericDocError $+      "Illegal hiding in postfix projection " P.<+> P.pretty arg+    _ -> return ()++-- | 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)++  -- 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 = ""+             }+        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+                    }++  -- 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 ⦄@.+        rejectPostfixProjectionWithHiding e2++        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++  -- 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+      C.HiddenArg _ _ -> nothingAppliedToHiddenArg e+      C.InstanceArg _ _ -> nothingAppliedToInstanceArg 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 = case rel of+              Relevant -> id+              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 (genericError $ "Let-expressions are not allowed in dot patterns") $+        localToAbstract (LetDefs ds) $ \ds' -> do+          e <- toAbstractCtx TopCtx e+          let info = ExprRange (getRange e0)+          return $ A.mkLet info ds' e+      C.Let _ _ Nothing -> genericError "Missing body in let-expression"++  -- Record construction+      C.Rec 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 i fs'')++  -- Record update+      C.RecUpdate r e fs -> do+        A.RecUpdate (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+      C.Dot r e  -> A.Dot (ExprRange r) <$> toAbstract e++  -- Pattern things+      C.As _ _ _ -> notAnExpression e+      C.Absurd _ -> notAnExpression e++  -- Impossible things+      C.ETel _  -> __IMPOSSIBLE__+      C.Equal{} -> genericError "Parse error: unexpected '='"+      C.Ellipsis _ -> genericError "Parse error: unexpected '...'"+      C.DoubleDot _ _ -> genericError "Parse error: unexpected '..'"++  -- 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 -> do+        let AppView e' args = appView e+        e'   <- toAbstract e'+        args <- toAbstract args+        return $ A.Tactic (ExprRange r) e' args++  -- 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 x+               (C.SectionApp (getRange (m , es)) [] (rawApp (Ident 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 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.+    n <- if not (isNoName name && isJust p) then pure n else do+           n' <- freshConcreteName (getRange $ newName n) 0 patternInTeleName+           pure $ fmap (\ n -> n { C.boundName = n' }) n+    n <- toAbstract n+    -- 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 n++instance ToAbstract C.LamBinding where+  type AbsOfCon C.LamBinding = Maybe A.LamBinding++  toAbstract (C.DomainFree x)  = do+    tac <- traverse toAbstract $ bnameTactic $ C.binderName $ namedArg x+    Just . A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)+  toAbstract (C.DomainFull tb) = fmap A.DomainFull <$> toAbstract tb++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+    tac <- traverse toAbstract $+             case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of+               []      -> Nothing+               tac : _ -> Just tac+               -- Invariant: all tactics are the same+               -- (distributed in the parser, TODO: don't)+    xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs+    return $ Just $ A.TBind r tac xs' t'+  toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ds)++-- | Scope check a module (top level function).+--+scopeCheckNiceModule+  :: Range+  -> Access+  -> C.Name+  -> C.Telescope+  -> ScopeM [A.Declaration]+  -> ScopeM A.Declaration+       -- ^ The returned declaration is an 'A.Section'.+scopeCheckNiceModule r p name tel checkDs+  | telHasOpenStmsOrModuleMacros tel = do+      -- 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!+      scopeCheckNiceModule noRange p noName_ [] $ singleton <$>+        scopeCheckNiceModule_ PublicAccess  -- See #4350++  | otherwise = do+        scopeCheckNiceModule_ p+  where+    -- The actual workhorse:+    scopeCheckNiceModule_ :: Access -> ScopeM A.Declaration+    scopeCheckNiceModule_ p = 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, PrivateAccess Inserted, 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 (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) noRange }+      return d++-- | Check whether a telescope has open declarations or module macros.+telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool+telHasOpenStmsOrModuleMacros = any yesBind+  where+    yesBind C.TBind{}     = False+    yesBind (C.TLet _ ds) = any yes ds+    yes C.ModuleMacro{}   = True+    yes C.Open{}          = True+    yes 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)+    yes (C.Mutual   _ ds) = any yes ds+    yes (C.Abstract _ ds) = any yes ds+    yes (C.Private _ _ ds) = any yes ds+    yes _                 = False++{- UNUSED+telHasLetStms :: C.Telescope -> Bool+telHasLetStms = any isLetBind+  where+    isLetBind C.TBind{} = False+    isLetBind C.TLet{}  = True+-}++-- | 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.+  -> 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 x qm tel checkDs = do+  printScope "module" 20 $ "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" 20 $ "inside module " ++ prettyShow x+      ds    <- checkDs+      scope <- getScope+      return (scope, A.Section r (qm `withRangesOfQ` x) tel ds)++  -- Binding is done by the caller+  printScope "module" 20 $ "after module " ++ prettyShow x+  return res++-- | Temporary data type to scope check a file.+data TopLevel a = TopLevel+  { topLevelPath           :: AbsolutePath+    -- ^ The file path from which we loaded this module.+  , topLevelExpectedName   :: C.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 file 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 : _) -> traceCall (SetRange $ getRange d) $+          genericError $ "No declarations allowed after top-level module."++        -- Otherwise, proceed.+        (outsideDecls, [ C.Module r m0 tel insideDecls ]) -> do+          -- If the module name is _ compute the name from the file path+          m <- if isNoName m0+                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 _ _ : _))+                       | C.toTopLevelModuleName m1 == 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+                         traceCall (SetRange $ getRange ds0) $ genericError+                           "Illegal declaration(s) before top-level module"++                    -- Otherwise, reconstruct the top-level module name+                    _ -> return $ C.QName $ setRange (getRange m0) $+                           C.simpleName $ stringToRawName $ rootNameModule file+                -- 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.+                  checkModuleName (C.toTopLevelModuleName m0) (SourceFile file) $ Just expectedMName+                  return m0+          setTopLevelModule m+          am <- toAbstract (NewModuleQName m)+          primitiveImport <- importPrimitives+          -- Scope check the declarations outside+          outsideDecls <- toAbstract (Declarations outsideDecls)+          (insideScope, insideDecl) <- scopeCheckModule r 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+          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; Prop)@ when 'optImportSorts'.+importPrimitives :: ScopeM [A.Declaration]+importPrimitives = do+    noImportSorts <- not . optImportSorts <$> pragmaOptions+    -- Add implicit `open import Agda.Primitive using (Set; Prop)`+    let agdaPrimitiveName   = Qual (C.simpleName "Agda") $ C.QName $ C.simpleName "Primitive"+        agdaSetName         = C.simpleName "Set"+        agdaPropName        = C.simpleName "Prop"+        usingDirective      = Using [ImportedName agdaSetName, ImportedName agdaPropName]+        directives          = ImportDirective noRange usingDirective [] [] Nothing+        importAgdaPrimitive = [C.Import noRange agdaPrimitiveName Nothing C.DoOpen directives]+    if noImportSorts+      then return []+      else 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+  fixs <- useScope scopeFixities  -- We need to pass the fixities to the nicifier for clause grouping+  let (result, warns') = runNice $ niceDeclarations fixs ds++  -- COMPILED pragmas are not allowed in safe mode unless we are in a builtin module.+  -- So we start by filtering out all the PragmaCompiled warnings if one of these two+  -- conditions is not met.+  isSafe    <- Lens.getSafeMode <$> pragmaOptions+  isBuiltin <- Lens.isBuiltinModule . filePath =<< getCurrentPath+  let warns = if isSafe && not isBuiltin then warns' else filter notOnlyInSafeMode warns'++  -- 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+      unless (null errs) $ do+        warnings $ NicifierIssue <$> ws+        tcerrs <- mapM warning_ $ NicifierIssue <$> errs+        setCurrentRange errs $ typeError $ NonFatalErrors 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+      throwError $ Exception (getRange e) $ pretty e+    Right ds -> ret ds++  where notOnlyInSafeMode = (PragmaCompiled_ /=) . declarationWarningName++-- | 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) = do+    -- When --safe is active the termination checker (Issue 586),+    -- positivity checker (Issue 1614) and the coverage checker+    -- may not be switched off, and polarities may not be assigned.+    ds <- ifM (Lens.getSafeMode <$> pragmaOptions)+               {- then -} (mapM noUnsafePragma ds)+               {- else -} (return ds)++    niceDecls DoWarn ds toAbstract+   where++     -- We need to dig deep into a declaration, otherwise it is possible+     -- to hide an illegal pragma in a block. Cf. Issue #3983+     noUnsafePragma :: C.Declaration -> TCM C.Declaration+     noUnsafePragma = \case+       C.Pragma pr                 -> warnUnsafePragma pr+       C.RecordDef r n dir lams ds -> C.RecordDef r n dir lams <$> mapM noUnsafePragma ds+       C.Record r n dir lams e ds  -> C.Record r n dir lams e <$> mapM noUnsafePragma ds+       C.Mutual r ds               -> C.Mutual r <$> mapM noUnsafePragma ds+       C.Abstract r ds             -> C.Abstract r <$> mapM noUnsafePragma ds+       C.Private r o ds            -> C.Private r o <$> mapM noUnsafePragma ds+       C.InstanceB r ds            -> C.InstanceB r <$> mapM noUnsafePragma ds+       C.Macro r ds                -> C.Macro r <$> mapM noUnsafePragma ds+       d -> pure d++     warnUnsafePragma :: C.Pragma -> TCM C.Declaration+     warnUnsafePragma pr = C.Pragma pr <$ do+       ifM (Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath)+         {- then -} (pure ())+         {- else -} $ case unsafePragma pr of+         Nothing -> pure ()+         Just w  -> setCurrentRange pr $ warning w++     unsafePragma :: C.Pragma -> Maybe Warning+     unsafePragma = \case+       C.NoCoverageCheckPragma{}    -> Just SafeFlagNoCoverageCheck+       C.NoPositivityCheckPragma{}  -> Just SafeFlagNoPositivityCheck+       C.PolarityPragma{}           -> Just SafeFlagPolarity+       C.NoUniverseCheckPragma{}    -> Just SafeFlagNoUniverseCheck+       C.InjectivePragma{}          -> Just SafeFlagInjective+       C.TerminationCheckPragma _ m -> case m of+         NonTerminating       -> Just SafeFlagNonTerminating+         Terminating          -> Just SafeFlagTerminating+         TerminationCheck     -> Nothing+         TerminationMeasure{} -> Nothing+         -- ASR (31 December 2015). We don't pattern-match on+         -- @NoTerminationCheck@ because the @NO_TERMINATION_CHECK@ pragma+         -- was removed. See Issue #1763.+         NoTerminationCheck -> Nothing+       -- exhaustive match to get told by ghc we should have a look at this+       -- when we add new pragmas.+       C.OptionsPragma{}    -> Nothing+       C.BuiltinPragma{}    -> Nothing+       C.ForeignPragma{}    -> Nothing+       C.StaticPragma{}     -> Nothing+       C.InlinePragma{}     -> Nothing+       C.ImpossiblePragma{} -> Nothing+       C.EtaPragma{}        -> Just SafeFlagEta+       C.WarningOnUsage{}   -> Nothing+       C.WarningOnImport{}  -> Nothing+       C.DisplayPragma{}    -> Nothing+       C.CatchallPragma{}   -> Nothing+       -- @RewritePragma@ already requires --rewriting which is incompatible with --safe+       C.RewritePragma{}    -> Nothing+       -- @CompilePragma@ already handled in the nicifier+       C.CompilePragma{}    -> Nothing+++newtype LetDefs = LetDefs (List1 C.Declaration)+newtype LetDef = LetDef NiceDeclaration++instance ToAbstract LetDefs where+  type AbsOfCon LetDefs = [A.LetBinding]++  toAbstract (LetDefs ds) =+    List1.concat <$> niceDecls DoWarn (List1.toList ds) (toAbstract . map LetDef)++instance ToAbstract LetDef where+  type AbsOfCon LetDef = List1 A.LetBinding+  toAbstract (LetDef d) =+    case d of+      NiceMutual _ _ _ _ d@[C.FunSig _ _ _ instanc macro info _ _ x t, C.FunDef _ _ abstract _ _ _ _ [cl]] ->+          do  when (abstract == AbstractDef) $ do+                genericError $ "`abstract` not allowed in let expressions"+              when (macro == MacroDef) $ do+                genericError $ "Macros cannot be defined in a let expression"+              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+              -- If InstanceDef set info to Instance+              let info' = case instanc of+                    InstanceDef _  -> makeInstance info+                    NotInstanceDef -> info+              -- There are sometimes two instances of the+              -- let-bound variable, one declaration and one+              -- definition. The first list element below is+              -- used to highlight the declared instance in the+              -- right way (see Issue 1618).+              return $ A.LetDeclaredVariable (A.mkBindName (setRange (getRange x') x)) :|+                     [ A.LetBind (LetRange $ getRange d) info' (A.mkBindName x) t e+                     ]++      -- irrefutable let binding, like  (x , y) = rhs+      NiceFunClause r PublicAccess ConcreteDef tc cc catchall d@(C.FunClause lhs@(C.LHS p0 [] []) rhs0 wh ca) -> do+        noWhereInLetBinding wh+        rhs <- letBindingMustHaveRHS rhs0+        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 $ NiceMutual r 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 dirs -> do+        whenJust (publicOpen dirs) $ \r -> setCurrentRange r $ warning UselessPublic+        m    <- toAbstract (OldModuleName x)+        adir <- openModule_ LetOpenModule x dirs+        let minfo = ModuleInfo+              { minfoRange  = r+              , minfoAsName = Nothing+              , minfoAsTo   = renamingRange dirs+              , minfoOpenShort = Nothing+              , minfoDirective = Just dirs+              }+        return $ singleton $ A.LetOpen minfo m adir++      NiceModuleMacro r p x modapp open dir -> do+        whenJust (publicOpen dir) $ \ r -> setCurrentRange r $ warning UselessPublic+        -- Andreas, 2014-10-09, Issue 1299: module macros in lets need+        -- to be private+        singleton <$> checkModuleMacro LetApply LetOpenModule r (PrivateAccess Inserted) x modapp open dir++      _   -> notAValidLetBinding d+    where+        letToAbstract (C.Clause top _catchall (C.LHS p [] []) rhs0 wh []) = do+            noWhereInLetBinding wh+            rhs <- letBindingMustHaveRHS rhs0+            (x, args) <- do+              res <- setCurrentRange p $ parseLHS (C.QName top) p+              case res of+                C.LHSHead x args -> return (x, args)+                C.LHSProj{} -> genericError $ "Copatterns not allowed in let bindings"+                C.LHSWith{} -> genericError $ "`with` patterns not allowed in let bindings"+                C.LHSEllipsis{} -> genericError "`...` not allowed in let bindings"++            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 d++        -- Named patterns not allowed in let definitions+        lambda e (Arg info (Named Nothing (A.VarP x))) =+                return $ A.Lam i (A.mkDomainFree $ unnamedArg info $ A.mkBinder x) e+            where i = ExprRange (fuseRange x e)+        lambda e (Arg info (Named Nothing (A.WildP i))) =+            do  x <- freshNoName (getRange i)+                return $ A.Lam i' (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ x) e+            where i' = ExprRange (fuseRange i e)+        lambda _ _ = notAValidLetBinding d++        noWhereInLetBinding :: C.WhereClause -> ScopeM ()+        noWhereInLetBinding = \case+          NoWhere -> return ()+          wh -> setCurrentRange wh $ genericError $ "`where` clauses not allowed in let bindings"+        letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr+        letBindingMustHaveRHS = \case+          C.RHS e -> return e+          C.AbsurdRHS -> genericError $ "Missing right hand side in let binding"++        -- 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 = \case+            A.VarP{}             -> yes+            A.ConP _ _ ps        -> mapM_ (checkValidLetPattern . namedArg) ps+            A.ProjP{}            -> no+            A.DefP{}             -> no+            A.WildP{}            -> yes+            A.AsP _ _ p          -> checkValidLetPattern p+            A.DotP{}             -> no+            A.AbsurdP{}          -> no+            A.LitP{}             -> no+            A.PatternSynP _ _ ps -> mapM_ (checkValidLetPattern . namedArg) ps+            A.RecP _ fs          -> mapM_ (checkValidLetPattern . _exprFieldA) fs+            A.EqualP{}           -> no+            A.WithP{}            -> no+            A.AnnP _ _ p         -> checkValidLetPattern p+          where+          yes = return ()+          no  = genericError "Not a valid let pattern"+++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.+    caseMaybe (niceHasAbstract d) id (\ a -> localTC $ \ e -> e { envAbstractMode = aDefToMode a }) $+    case d of++  -- Axiom (actual postulate)+    C.Axiom r p a i rel x t -> do+      -- check that we do not postulate in --safe mode, unless it is a+      -- builtin module with safe postulates+      whenM ((Lens.getSafeMode <$> commandLineOptions) `and2M`+             (not <$> (Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath)))+            (warning $ SafeFlagPostulate x)+      -- check the postulate+      singleton <$> toAbstractNiceAxiom AxiomName d++    C.NiceGeneralize r p i tac x t -> do+      reportSLn "scope.decl" 10 $ "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 t -> do+      unless (p == PublicAccess) $ genericError "Record fields can not be private"+      -- Interaction points for record fields have already been introduced+      -- when checking the type of the record constructor.+      -- To avoid introducing interaction points (IP) twice, we turn+      -- all question marks to underscores.  (See issue 1138.)+      let maskIP (C.QuestionMark r _) = C.Underscore r Nothing+          maskIP e                     = e+      tac <- traverse (toAbstractCtx TopCtx) tac+      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 t' ]++  -- Primitive function+    PrimitiveFunction r p a x t -> do+      t' <- traverse (toAbstractCtx TopCtx) t+      f  <- getConcreteFixity x+      y  <- freshAbstractQName f x+      bindName p PrimName x y+      return [ A.Primitive (mkDefInfo x f p a r) y t' ]++  -- Definitions (possibly mutual)+    NiceMutual r tc cc pc ds -> do+      ds' <- toAbstract ds+      -- We only termination check blocks that do not have a measure.+      return [ A.Mutual (MutualInfo tc cc pc r) ds' ]++    C.NiceRecSig r 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) x' ls' t' ]++    C.NiceDataSig r p a pc uc x ls t -> do+        reportSLn "scope.data.sig" 20 ("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) 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 <$> toAbstractNiceAxiom kind (C.Axiom r p a i rel x t)++  -- Function definitions+    C.FunDef r ds a i _ _ x cs -> do+        printLocals 10 $ "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__+        let delayed = NotDelayed+        -- (delayed, cs) <- translateCopatternClauses cs -- TODO+        f <- getConcreteFixity x+        return [ A.FunDef (mkDefInfoInstance x f PublicAccess a i NotMacroDef r) x' delayed cs ]++  -- Uncategorized function clauses+    C.NiceFunClause _ _ _ _ _ _ (C.FunClause lhs _ _ _) ->+      genericError $+        "Missing type signature for left hand side " ++ prettyShow lhs+    C.NiceFunClause{} -> __IMPOSSIBLE__++  -- Data definitions+    C.NiceDataDef r o a _ uc x pars cons -> do+        reportSLn "scope.data.def" 20 ("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)+          _ -> genericError $ "Missing type signature for data definition " ++ prettyShow x+        ensureNoLetStms pars+        withLocalVars $ do+          gvars <- bindGeneralizablesIfInserted o ax+          -- Check for duplicate constructors+          do cs <- mapM conName cons+             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" 20 $ "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 (RecordDirectives ind eta pat cm) pars fields -> do+      reportSLn "scope.rec.def" 20 ("checking " ++ show o ++ " RecDef for " ++ prettyShow x)+      -- #3008: Termination pragmas are ignored in records+      checkNoTerminationPragma InRecordDef fields+      -- Andreas, 2020-04-19, issue #4560+      -- 'pattern' declaration is incompatible with 'coinductive' or 'eta-equality'.+      whenJust pat $ \ r -> do+        let warn = setCurrentRange r . warning . UselessPatternDeclarationForRecord+        if | Just (Ranged _ CoInductive) <- ind -> warn "coinductive"+           | Just YesEta                 <- eta -> warn "eta"+           | otherwise -> return ()++      (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)+        _ -> genericError $ "Missing type signature for record definition " ++ prettyShow 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" 15 "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" 15 "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+           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+        -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.+        cm' <- forM cm $ \ (c, _) -> bindRecordConstructorName c kind a p+        let inst = caseMaybe cm NotInstanceDef snd+        printScope "rec" 15 "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 x@(C.QName name) tel ds -> do+      reportSDoc "scope.decl" 70 $ vcat $+        [ text $ "scope checking NiceModule " ++ prettyShow x+        ]++      adecl <- traceCall (ScopeCheckDeclaration $ NiceModule r p a x tel []) $ do+        scopeCheckNiceModule r p 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{} _ _ ->+      genericError $ "Local modules cannot have qualified names"++    NiceModuleMacro r p x modapp open dir -> do+      reportSDoc "scope.decl" 70 $ vcat $+        [ text $ "scope checking NiceModuleMacro " ++ prettyShow x+        ]++      adecl <- checkModuleMacro Apply TopOpenModule r p 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 = traceCall (SetRange $ getRange 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 ""++      -- First scope check the imported module and return its name and+      -- interface. This is done with that module as the top-level module.+      -- This is quite subtle. We rely on the fact that when setting the+      -- top-level module and generating a fresh module name, the generated+      -- name will be exactly the same as the name generated when checking+      -- the imported module.+      (m, i) <- withCurrentModule noModuleName $ withTopLevelModule x $ do+        m <- toAbstract $ NewModuleQName x  -- (No longer erases the contents of @m@.)+        printScope "import" 10 "before import:"+        (m, i) <- scopeCheckImport m+        printScope "import" 10 $ "scope checked import: " ++ prettyShow i+        -- We don't want the top scope of the imported module (things happening+        -- before the module declaration)+        return (m, 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 (PrivateAccess Inserted) y m+           return (C.QName y, asRange a, Just y)++         _ -> do+           -- Don't bind if @import ... as _@ with "no name"+           whenNothing as $ bindQModule (PrivateAccess Inserted) 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" 10 "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+      return [ A.Mutual mi [A.UnquoteDecl mi [ mkDefInfoInstance x fx p a i NotMacroDef r | (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+      return [ A.UnquoteDef [ mkDefInfo x fx PublicAccess a r | (fx, x) <- zip fxs xs ] ys e ]++    NicePatternSyn r a n as p -> do+      reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ prettyShow n+      (as, p) <- withLocalVars $ do+         p  <- toAbstract =<< parsePatternSyn p+         when (containsAsPattern p) $+           typeError $ GenericError $+             "@-patterns are not allowed in pattern synonyms"+         checkPatternLinearity p $ \ys ->+           typeError $ RepeatedVariablesInPattern ys+         bindVarsToBind+         let err = "Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead."+         p <- noDotorEqPattern err p+         as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as+         unlessNull (patternVars p List.\\ map unArg as) $ \ xs -> do+           typeError . GenericDocError =<< do+             "Unbound variables in pattern synonym: " <+>+               sep (map prettyA 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 unVarName (VarName a _) = return a+            unVarName _ = typeError $ UnusedVariableInPatternSynonym++    d@NiceLoneConstructor{} -> withCurrentCallStack $ \ stk -> do+      warning $ NicifierIssue (DeclarationWarning stk (InvalidConstructorBlock (getRange d)))+      pure []++    where+      -- checking postulate or type sig. without checking safe flag+      toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM A.Declaration+      toAbstractNiceAxiom kind (C.Axiom r p a i info x t) = do+        t' <- 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+        return $ A.Axiom kind (mkDefInfoInstance x f p a i isMacro r) info mp y t'+      toAbstractNiceAxiom _ _ = __IMPOSSIBLE__++unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr)+unGeneralized (A.Generalized s t) = (s, t)+unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e+unGeneralized t = (mempty, t)++collectGeneralizables :: ScopeM a -> ScopeM (Set I.QName, a)+collectGeneralizables m = 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 I.QName -> ScopeM (Map I.QName I.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 I.QName I.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)++-- | 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) $+      genericError $ "Definition in different module than its type signature"++-- | 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 =+  fromMaybe [] . Map.lookup x . nsModules . thingsInScope [PublicNS, PrivateNS] <$> getCurrentScope++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 -> PrivateAccess Inserted+           _           -> p+    p'' = case a of+            AbstractDef -> PrivateAccess Inserted+            _           -> 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 -> PrivateAccess Inserted+           _           -> p++instance ToAbstract DataConstrDecl where+  type AbsOfCon DataConstrDecl = A.Declaration++  toAbstract (DataConstrDecl m a p d) = do+    case d of+      C.Axiom r p1 a1 i info x t -> do -- rel==Relevant+        -- unless (p1 == p) __IMPOSSIBLE__  -- This invariant is currently violated by test/Succeed/Issue282.agda+        unless (a1 == a) __IMPOSSIBLE__+        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" 15 "bound constructor"+        return $ A.Axiom ConName (mkDefInfoInstance x f p a i NotMacroDef r)+                         info Nothing y t'+      _ -> errorNotConstrDecl d++errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a+errorNotConstrDecl d = typeError . GenericDocError $+        "Illegal declaration in data type definition " P.$$+        P.nest 2 (P.vcat $ map pretty (notSoNiceDeclarations d))++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 . concat <$> do+   forM xs $ \ x -> do+    e <- toAbstract $ OldQName x Nothing+    case e of+      A.Def x          -> return [ x ]+      A.Proj _ p | Just x <- getUnambiguous p -> return [ x ]+      A.Proj _ x       -> genericError $ "REWRITE used on ambiguous name " ++ prettyShow x+      A.Con c | Just x <- getUnambiguous c -> return [ x ]+      A.Con x          -> genericError $ "REWRITE used on ambiguous name " ++ prettyShow x+      A.Var x          -> genericError $ "REWRITE used on parameter " ++ prettyShow x ++ " instead of on a defined symbol"+      _       -> __IMPOSSIBLE__+  toAbstract (C.ForeignPragma _ rb s) = [] <$ addForeignCode (rangedThing rb) s+  toAbstract (C.CompilePragma _ rb x s) = do+    me <- toAbstract $ MaybeOldQName $ OldQName x Nothing+    case me of+      Nothing -> [] <$ notInScopeWarning x+      Just e  -> do+        let err what = genericError $ "Cannot COMPILE " ++ what ++ " " ++ prettyShow x+        y <- case e of+          A.Def x             -> return x+          A.Proj _ p | Just x <- getUnambiguous p -> return x+          A.Proj _ x          -> err "ambiguous projection"+          A.Con c | Just x <- getUnambiguous c -> return x+          A.Con x             -> err "ambiguous constructor"+          A.PatternSyn{}      -> err "pattern synonym"+          A.Var{}             -> err "local variable"+          _                   -> __IMPOSSIBLE__+        return [ A.CompilePragma rb y s ]++  toAbstract (C.StaticPragma _ x) = do+      e <- toAbstract $ OldQName x Nothing+      y <- case e of+          A.Def  x -> return x+          A.Proj _ p | Just x <- getUnambiguous p -> return x+          A.Proj _ x -> genericError $+            "STATIC used on ambiguous name " ++ prettyShow x+          _        -> genericError "Target of STATIC pragma should be a function"+      return [ A.StaticPragma y ]+  toAbstract (C.InjectivePragma _ x) = do+      e <- toAbstract $ OldQName x Nothing+      y <- case e of+          A.Def  x -> return x+          A.Proj _ p | Just x <- getUnambiguous p -> return x+          A.Proj _ x -> genericError $+            "INJECTIVE used on ambiguous name " ++ prettyShow x+          _        -> genericError "Target of INJECTIVE pragma should be a defined symbol"+      return [ A.InjectivePragma y ]+  toAbstract (C.InlinePragma _ b x) = do+      e <- toAbstract $ OldQName x Nothing+      let sINLINE = if b then "INLINE" else "NOINLINE"+      y <- case e of+          A.Def  x -> return x+          A.Proj _ p | Just x <- getUnambiguous p -> return x+          A.Proj _ x -> genericError $+            sINLINE ++ " used on ambiguous name " ++ prettyShow x+          _        -> genericError $ "Target of " ++ sINLINE ++ " pragma should be a function"+      return [ A.InlinePragma b y ]+  toAbstract (C.BuiltinPragma _ rb qx)+    | isUntypedBuiltin b = do+        q <- toAbstract $ 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.+    | 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+                genericWarning $ P.text $+                   "BUILTIN " ++ b ++ " declares an identifier " +++                   "(no longer expects an already defined identifier)"+                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 ]+            _ -> genericError $+              "Pragma BUILTIN " ++ b ++ ": expected unqualified identifier, " +++              "but found " ++ prettyShow qx+    | otherwise = do+          q0 <- toAbstract $ ResolveQName qx++          -- Andreas, 2020-04-12, pr #4574.  For highlighting purposes:+          -- Rebind 'BuiltinPrim' as 'PrimName' and similar.+          q <- case (q0, builtinKindOfName b, 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 = rangedThing rb++  toAbstract (C.EtaPragma _ x) = do+    e <- toAbstract $ OldQName x Nothing+    case e of+      A.Def x -> return [ A.EtaPragma x ]+      _       -> do+       e <- showA e+       genericError $ "Pragma ETA: expected identifier, " +++         "but found expression " ++ e++  toAbstract (C.DisplayPragma _ lhs rhs) = withLocalVars $ do+    let err = genericError "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 <- 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{}    -> genericError $ "Invalid pattern " ++ prettyShow top+        FieldName     (d :| [])     -> return . (False,) $ anameName d+        FieldName ds                -> genericError $ "Ambiguous projection " ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)+        ConstructorName _ (d :| []) -> return . (False,) $ anameName d+        ConstructorName _ ds        -> genericError $ "Ambiguous constructor " ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)+        UnknownName                 -> notInScopeError top+        PatternSynResName (d :| []) -> return . (True,) $ anameName d+        PatternSynResName ds        -> genericError $ "Ambiguous pattern synonym" ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)++    lhs <- toAbstract $ LeftHandSide top lhs+    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+      let mkP | isPatSyn  = A.PatternSynP (PatRange $ getRange lhs) (unambiguous hd)+              | otherwise = A.DefP (PatRange $ getRange lhs) (unambiguous hd)+      p <- expandPatternSynonyms $ mkP 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 <- toAbstract rhs+    return [A.DisplayPragma hd ps rhs]++  -- A warning attached to an ambiguous name shall apply to all disambiguations.+  toAbstract (C.WarningOnUsage _ x str) = do+    ys <- fmap anameName <$> toAbstractExistingName x+    forM_ ys $ \ qn -> stLocalUserWarnings `modifyTCLens` Map.insert qn 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__++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+    printLocals 10 "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 -> do+      -- Andreas, 2016-07-17 issues #2081 and #2101+      -- where-declarations are automatically private.+      -- This allows their type signature to be checked InAbstractMode.+      whereToAbstract1 r Nothing (singleton $ C.Private noRange Inserted ds) inner+    SomeWhere _ m a ds0 -> List1.ifNull ds0 warnEmptyWhere {-else-} $ \ ds -> do+      -- Named where-modules do not default to private.+      whereToAbstract1 r (Just (m, a)) ds inner+  where+  ret = (,A.noWhereDecls) <$> inner+  warnEmptyWhere = do+    setCurrentRange r $ warning EmptyWhere+    ret++whereToAbstract1+  :: Range                            -- ^ The range of the @where@-block.+  -> 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 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, PrivateAccess Inserted)+           -- unnamed where's are private+  old <- getCurrentModule+  am  <- toAbstract (NewModuleName m)+  (scope, d) <- scopeCheckModule r (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 noRange }+  return (x, A.WhereDecls (am <$ whname) $ singleton d)++data TerminationOrPositivity = Termination | Positivity+  deriving (Show)++data WhereOrRecord = InWhereBlock | InRecordDef++checkNoTerminationPragma :: Foldable f => WhereOrRecord -> f C.Declaration -> ScopeM ()+checkNoTerminationPragma b ds =+  mapM_ (\ (p, r) -> warning $ GenericUseless r $ P.vcat [ P.text $ show p ++ " pragmas are ignored in " ++ what b+                                                         , P.text $ "(see " ++ issue b ++ ")" ])+        (foldMap terminationPragmas ds)+  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++terminationPragmas :: C.Declaration -> [(TerminationOrPositivity, Range)]+terminationPragmas (C.Private  _ _      ds) = concatMap terminationPragmas ds+terminationPragmas (C.Abstract _        ds) = concatMap terminationPragmas ds+terminationPragmas (C.InstanceB _       ds) = concatMap terminationPragmas ds+terminationPragmas (C.Mutual _          ds) = concatMap terminationPragmas ds+terminationPragmas (C.Module _ _ _      ds) = concatMap terminationPragmas ds+terminationPragmas (C.Macro _           ds) = concatMap terminationPragmas ds+terminationPragmas (C.Record _ _ _ _ _  ds) = concatMap terminationPragmas ds+terminationPragmas (C.RecordDef _ _ _ _ ds) = concatMap terminationPragmas ds+terminationPragmas (C.Pragma (TerminationCheckPragma r _)) = [(Termination, r)]+terminationPragmas (C.Pragma (NoPositivityCheckPragma r))  = [(Positivity, r)]+terminationPragmas _                                       = []++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' [A.WithExpr] [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++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 <- parsePattern p+        p <- toAbstract p+        checkPatternLinearity p (typeError . RepeatedVariablesInPattern)+        bindVarsToBind+        p <- toAbstract 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++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+  toAbstract (RightHandSide [] []    (_  , []) rhs         NoWhere) = toAbstract rhs+  toAbstract (RightHandSide [] nes   (lv , cs) C.AbsurdRHS NoWhere) = do+    let (ns , es) = unzipWith (\ (Named nm e) -> (NewName WithBound . C.mkBoundName_ <$> nm, e)) nes+    es <- toAbstractCtx TopCtx es+    lvars0 <- getLocalVars+    ns <- toAbstract ns+    lvars1 <- getLocalVars+    let lv' = dropEnd (length lvars0) lvars1 ++ lv+    let cs' = for cs $ \ c -> setLocalVars lv' $> c+    let nes = 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  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++data LeftHandSide = LeftHandSide C.QName C.Pattern++instance ToAbstract LeftHandSide where+    type AbsOfCon LeftHandSide = A.LHS++    toAbstract (LeftHandSide top lhs) =+      traceCall (ScopeCheckLHS top lhs) $ do+        reportSLn "scope.lhs" 5 $ "original lhs: " ++ prettyShow lhs+        reportSLn "scope.lhs" 60 $ "patternQNames: " ++ prettyShow (patternQNames lhs)+        reportSLn "scope.lhs" 60 $ "original lhs (raw): " ++ show lhs+        lhscore <- parseLHS top lhs+        let ell = hasExpandedEllipsis lhscore+        reportSLn "scope.lhs" 5 $ "parsed lhs: " ++ prettyShow lhscore+        reportSLn "scope.lhs" 60 $ "parsed lhs (raw): " ++ show lhscore+        printLocals 10 "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 lhscore+        bindVarsToBind+        -- reportSLn "scope.lhs" 5 $ "parsed lhs patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'+        reportSLn "scope.lhs" 60 $ "parsed lhs patterns: " ++ show lhscore+        printLocals 10 "checked pattern:"+        -- scope check dot patterns+        lhscore <- toAbstract lhscore+        -- reportSLn "scope.lhs" 5 $ "parsed lhs dot patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'+        reportSLn "scope.lhs" 60 $ "parsed lhs dot patterns: " ++ show lhscore+        printLocals 10 "checked dots:"+        return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore++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 _ wps _ -> 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 i (Named mn (A.EqualP r es))) : ps) = setCurrentRange p $ do+      -- Face constraint patterns must be defaultNamedArg; check this:+      unless (getModality i == defaultModality) __IMPOSSIBLE__+      when (hidden     i) $ warn i $ "Face constraint patterns cannot be hidden arguments"+      when (isInstance i) $ warn i $ "Face constraint patterns cannot be instance arguments"+      whenJust mn $ \ x -> setCurrentRange x $ warn x $ P.hcat+          [ "Ignoring name `", P.pretty x, "` given to face constraint pattern" ]+      go (acc `mappend` (r, es)) ps+    go (r, es@(_:_)) ps = (defaultNamedArg (A.EqualP r es) :) <$> mergeEqualPs ps+    go (_, []) []       = return []+    go (_, []) (p : ps) = (p :) <$> mergeEqualPs ps++    warn r d = warning $ GenericUseless (getRange r) d++-- does not check pattern linearity+instance ToAbstract C.LHSCore where+    type AbsOfCon C.LHSCore = (A.LHSCore' C.Expr)++    toAbstract (C.LHSHead x ps) = do+        x <- withLocalVars $ do+          setLocalVars []+          toAbstract (OldName x)+        A.LHSHead x <$> do mergeEqualPs =<< toAbstract ps+    toAbstract (C.LHSProj d ps1 l ps2) = do+        unless (null ps1) $ typeError $ GenericDocError $+          "Ill-formed projection pattern" P.<+> P.pretty (foldl C.AppP (C.IdentP d) ps1)+        qx <- resolveName d+        ds <- case qx of+                FieldName ds -> return $ fmap anameName ds+                UnknownName -> notInScopeError d+                _           -> genericError $+                  "head of copattern needs to be a field identifier, but "+                  ++ prettyShow d ++ " isn't one"+        A.LHSProj (AmbQ ds) <$> toAbstract l <*> (mergeEqualPs =<< toAbstract ps2)+    toAbstract (C.LHSWith core wps ps) = do+      liftA2 A.lhsCoreApp+        (liftA2 A.lhsCoreWith+          (toAbstract core)+          (map defaultArg <$> toAbstract wps))+        (toAbstract 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.+    toAbstract (C.LHSEllipsis _ p) = do+      ap <- toAbstract p+      bindVarsToBind+      return ap++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 (Named n e) = Named n <$> toAbstract e++{- 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 ::+  Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)+resolvePatternIdentifier r x ns = do+  reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ prettyShow x ++ " at source position " ++ prettyShow r+  px <- toAbstract (PatName x ns)+  case px of+    VarPatName y         -> do+      reportSLn "scope.pat" 60 $ "  resolved to VarPatName " ++ prettyShow y ++ " with range " ++ prettyShow (getRange y)+      return $ VarP $ A.mkBindName y+    ConPatName ds        -> return $ ConP (ConPatInfo ConOCon (PatRange r) ConPatEager)+                                          (AmbQ $ fmap anameName ds) []+    PatternSynPatName ds -> return $ PatternSynP (PatRange r)+                                                 (AmbQ $ fmap anameName ds) []++-- | 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.+  -> NAPs C.Expr          -- ^ Arguments of application.+  -> ScopeM (A.Pattern' C.Expr)+applyAPattern p0 p ps = do+  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+      A.AnnP{}    -> failure+  where+    failure = typeError $ InvalidPattern p0++instance ToAbstract C.Pattern where+    type AbsOfCon C.Pattern = A.Pattern' C.Expr++    toAbstract (C.IdentP x) =+      resolvePatternIdentifier (getRange x) x Nothing++    toAbstract (AppP (QuoteP _) p)+      | IdentP x <- namedArg p,+        visible p = do+      e <- toAbstract (OldQName x Nothing)+      A.LitP (PatRange $ getRange x) . LitQName <$> quotedName e++    toAbstract (QuoteP r) =+      genericError "quote must be applied to an identifier"++    toAbstract p0@(AppP p q) = do+        reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p+        p <- distributeDots p+        reportSLn "scope.pat" 50 $ "distributeDots after  = " ++ show p+        (p', q') <- toAbstract (p, q)+        applyAPattern p0 p' $ singleton q'++        where+            distributeDots :: C.Pattern -> ScopeM C.Pattern+            distributeDots p@(C.DotP r e) = distributeDotsExpr r e+            distributeDots p = return p++            distributeDotsExpr :: Range -> C.Expr -> ScopeM C.Pattern+            distributeDotsExpr r e = parseRawApp e >>= \case+              C.App r e a     ->+                AppP <$> distributeDotsExpr r e+                     <*> (traverse . traverse) (distributeDotsExpr r) a+              OpApp r q ns as ->+                case (traverse . traverse . traverse) fromNoPlaceholder as of+                  Just as -> OpAppP r q ns <$>+                    (traverse . traverse . traverse) (distributeDotsExpr r) as+                  Nothing -> return $ C.DotP r e+              Paren r e -> ParenP r <$> distributeDotsExpr r e+              _ -> return $ C.DotP 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++    toAbstract p0@(OpAppP r op ns ps) = do+        reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0+        p  <- resolvePatternIdentifier (getRange op) op (Just ns)+        ps <- toAbstract ps+        applyAPattern p0 p ps++    toAbstract (EllipsisP _ mp) = maybe __IMPOSSIBLE__ toAbstract mp++    -- Removed when parsing+    toAbstract (HiddenP _ _)   = __IMPOSSIBLE__+    toAbstract (InstanceP _ _) = __IMPOSSIBLE__+    toAbstract (RawAppP _ _)   = __IMPOSSIBLE__++    toAbstract p@(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 "_"+    toAbstract (C.ParenP _ p)   = toAbstract p+    toAbstract (C.LitP r l)     = setCurrentRange r $ A.LitP (PatRange r) l <$ checkLiteral l++    toAbstract p0@(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) >>= \case+        VarPatName x        -> A.AsP (PatRange r) (A.mkBindName x) <$> toAbstract p+        ConPatName{}        -> ignoreAsPat False+        PatternSynPatName{} -> ignoreAsPat True+      where+      -- An @-bound name which shadows a constructor is illegal and becomes dead code.+      ignoreAsPat b = do+        setCurrentRange x $ warning $ AsPatternShadowsConstructorOrPatternSynonym b+        toAbstract p++    toAbstract p0@(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.+    toAbstract p0@(C.DotP 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++    toAbstract p0@(C.AbsurdP r)    = return $ A.AbsurdP (PatRange r)+    toAbstract (C.RecP r fs)       = A.RecP (PatRange r) <$> mapM (traverse toAbstract) fs+    toAbstract (C.WithP r p)       = A.WithP (PatRange r) <$> toAbstract p++-- | 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 -> Set A.Name -> OpAppArgs -> ScopeM A.Expr+toAbstractOpApp op ns es = do+    -- Replace placeholders with bound variables.+    (binders, es) <- replacePlaceholders es+    -- Get the notation for the operator.+    nota <- getNotation op ns+    let parts = notation nota+    -- We can throw away the @BindingHoles@, since binders+    -- have been preprocessed into @OpApp C.Expr@.+    let nonBindingParts = filter (not . isBindingHole) parts+    -- 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 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 is filled with an expression in @InsideOperandCtx@.+    inside f [x]          es    = right f x es+    inside f (IdPart _ : xs) es = inside f xs es+    inside f (_  : xs) (e : es) = do+        e  <- toAbsOpArg InsideOperandCtx e+        es <- inside f xs es+        return (e : es)+    inside _ (_ : _) [] = __IMPOSSIBLE__+    inside _ []         _  = __IMPOSSIBLE__++    -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.+    right _ (IdPart _)  [] = return []+    right f _          [e] = do+        let pref = inferParenPref e+        e <- toAbsOpArg (RightOperandCtx f pref) e+        return [e]+    right _ _     _  = __IMPOSSIBLE__++    replacePlaceholders ::+      OpAppArgs' 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.mkBinder_ x) : ls+               , set (Left (Var x)) a : ns+               )+      where+      set :: a -> NamedArg b -> NamedArg a+      set x arg = fmap (fmap (const x)) arg+++{--------------------------------------------------------------------------+    Things we parse but are not part of the Agda file syntax+ --------------------------------------------------------------------------}++-- | Content of interaction hole.++instance ToAbstract C.HoleContent where+  type AbsOfCon C.HoleContent = A.HoleContent   toAbstract = \case     HoleContentExpr e     -> HoleContentExpr <$> toAbstract e     HoleContentRewrite es -> HoleContentRewrite <$> toAbstract es

src/full/Agda/Syntax/Translation/InternalToAbstract.hs view

@@ -1,6 +1,4 @@ {-# LANGUAGE NondecreasingIndentation   #-}-{-# LANGUAGE TypeFamilies               #-}  -- for type equality ~-{-# LANGUAGE UndecidableInstances       #-}  {-|     Translating from internal syntax to abstract syntax. Enables nice@@ -23,26 +21,24 @@   , reifyDisplayFormP   ) where -import Prelude hiding (mapM_, mapM, null)+import Prelude hiding (null)  import Control.Applicative (liftA2) import Control.Arrow ((&&&))-import Control.Monad.State hiding (mapM_, mapM)+import Control.Monad.State -import Data.Foldable (Foldable, foldMap) import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe-import Data.Monoid ( Monoid, mempty, mappend ) import Data.Semigroup ( Semigroup, (<>) ) import Data.Set (Set) import qualified Data.Set as Set-import Data.Traversable (traverse, mapM)+import qualified Data.Text as T+import Data.Traversable (mapM)  import Agda.Syntax.Literal import Agda.Syntax.Position import Agda.Syntax.Common-import Agda.Syntax.Fixity import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Concrete (FieldAssignment'(..)) import Agda.Syntax.Info as Info@@ -55,7 +51,6 @@ import Agda.Syntax.Scope.Base (inverseScopeLookupName)  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Reduce import {-# SOURCE #-} Agda.TypeChecking.Records import Agda.TypeChecking.CompiledClause (CompiledClauses'(Fail))@@ -72,6 +67,8 @@ 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.Maybe import Agda.Utils.Monad@@ -86,7 +83,7 @@   -- | Like @reify@ but instantiates blocking metas, useful for reporting.-reifyUnblocked :: Reify i a => i -> TCM a+reifyUnblocked :: Reify i => i -> TCM (ReifiesTo i) reifyUnblocked t = locallyTCState stInstantiateBlocking (const True) $ reify t  @@ -140,42 +137,45 @@  -- Conditional reification to omit terms that are not shown -------------- -reifyWhenE :: (Reify i Expr, MonadReify m) => Bool -> i -> m Expr+reifyWhenE :: (Reify i, MonadReify m, Underscore (ReifiesTo i)) => Bool -> i -> m (ReifiesTo i) reifyWhenE True  i = reify i reifyWhenE False t = return underscore  -- Reification ------------------------------------------------------------  type MonadReify m =-  ( MonadReduce m-  , MonadAddContext m+  ( PureTCM m   , MonadInteractionPoints m   , MonadFresh NameId m-  , HasConstInfo m-  , HasOptions m-  , HasBuiltins m-  , MonadDebug m   ) -class Reify i a | i -> a where-    reify     :: MonadReify m => i -> m a+class Reify i where+    type ReifiesTo i +    reify :: MonadReify m => i -> m (ReifiesTo i)+     --   @reifyWhen False@ should produce an 'underscore'.     --   This function serves to reify hidden/irrelevant things.-    reifyWhen :: MonadReify m => Bool -> i -> m a+    reifyWhen :: MonadReify m => Bool -> i -> m (ReifiesTo i)     reifyWhen _ = reify -instance Reify Bool Bool where+instance Reify Bool where+    type ReifiesTo Bool = Bool     reify = return -instance Reify Name Name where+instance Reify Name where+    type ReifiesTo Name = Name     reify = return -instance Reify Expr Expr where+instance Reify Expr where+    type ReifiesTo Expr = Expr+     reifyWhen = reifyWhenE     reify = return -instance Reify MetaId Expr where+instance Reify MetaId where+    type ReifiesTo MetaId = Expr+     reifyWhen = reifyWhenE     reify x@(MetaId n) = do       b <- asksTC envPrintMetasBare@@ -204,12 +204,14 @@ --   reifyWhen = reifyWhenE --   reify d = reifyTerm False $ dtermToTerm d -instance Reify DisplayTerm Expr where+instance Reify DisplayTerm where+  type ReifiesTo DisplayTerm = Expr+   reifyWhen = reifyWhenE-  reify d = case d of+  reify = \case     DTerm v -> reifyTerm False v     DDot  v -> reify v-    DCon c ci vs -> apps (A.Con (unambiguous (conName c))) =<< reify vs+    DCon c ci vs -> recOrCon (conName c) ci =<< reify vs     DDef f es -> elims (A.Def f) =<< reify es     DWithApp u us es0 -> do       (e, es) <- reify (u, us)@@ -332,9 +334,9 @@      displayLHS       :: MonadReify m-      => A.Patterns   -- ^ Patterns to substituted into display term.-      -> DisplayTerm  -- ^ Display term.-      -> m (QName, A.Patterns, A.Patterns)  -- ^ New head, patterns, with-patterns.+      => 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         let (f, vs, es) = flattenWith d         ps  <- mapM elimToPat vs@@ -349,7 +351,7 @@         elimToPat (I.Apply arg) = argToPat arg         elimToPat (I.Proj o d)  = return $ defaultNamedArg $ A.ProjP patNoRange o $ unambiguous d -        -- | Substitute variables in display term by patterns.+        -- Substitute variables in display term by patterns.         termToPat :: MonadReify m => DisplayTerm -> m (Named_ A.Pattern)          -- Main action HERE:@@ -364,7 +366,7 @@         termToPat (DTerm (I.Def _ [])) = return $ unnamed $ A.WildP patNoRange         termToPat (DDef _ [])          = return $ unnamed $ A.WildP patNoRange -        termToPat (DTerm (I.Lit l))    = return $ unnamed $ A.LitP l+        termToPat (DTerm (I.Lit l))    = return $ unnamed $ A.LitP patNoRange l          termToPat (DDot v)             = unnamed . A.DotP patNoRange <$> termToExpr v         termToPat v                    = unnamed . A.DotP patNoRange <$> reify v@@ -398,11 +400,15 @@               apps e =<< argsToExpr vs             _ -> return underscore -instance Reify Literal Expr where+instance Reify Literal where+  type ReifiesTo Literal = Expr+   reifyWhen = reifyWhenE-  reify l = return (A.Lit l)+  reify l = return $ A.Lit empty l -instance Reify Term Expr where+instance Reify Term where+  type ReifiesTo Term = Expr+   reifyWhen = reifyWhenE   reify v = reifyTerm True v @@ -417,7 +423,7 @@        let a = case unArg t of                 I.Lam _ (NoAbs _ b)    -> Just b                 I.Lam _ (Abs   _ b)-                  | not $ 0 `freeIn` b -> Just (strengthen __IMPOSSIBLE__ b)+                  | not $ 0 `freeIn` b -> Just (strengthen impossible b)                 _                      -> Nothing        case a of          Just a -> return (path, [I.Apply l, I.Apply (setHiding Hidden $ defaultArg a), I.Apply lhs, I.Apply rhs])@@ -444,70 +450,78 @@     -- only show up in errors. Check the spined form!     _ | I.Var n (I.Proj _ p : es) <- v,         Just name <- getGeneralizedFieldName p -> do-      let fakeName = (qnameName p) { nameConcrete = C.Name noRange C.InScope [C.Id name] } -- TODO: infix names!?+      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-        elims (A.Var x) =<< reify es-    I.Def x es   -> do-      reportSLn "reify.def" 100 $ "reifying def " ++ prettyShow x-      (x,es) <- reifyPathPConstAsPath x es+    I.Var n es -> do+      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+      (x, es) <- reifyPathPConstAsPath x es       reifyDisplayForm x es $ reifyDef expandAnonDefs x es     I.Con c ci vs -> do       let x = conName c       isR <- isGeneratedRecordConstructor x-      case isR || ci == ConORec of-        True -> do+      if isR || ci == ConORec+        then do           showImp <- showImplicitArguments           let keep (a, v) = showImp || visible a-          r  <- getConstructorData x+          r <- getConstructorData x           xs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r           vs <- map unArg <$> reify (fromMaybe __IMPOSSIBLE__ $ allApplyElims vs)           return $ A.Rec noExprInfo $ map (Left . uncurry FieldAssignment . mapFst unDom) $ filter keep $ zip xs vs-        False -> reifyDisplayForm x vs $ do+        else reifyDisplayForm x vs $ do           def <- getConstInfo x-          let Constructor{conPars = np} = theDef def+          let Constructor {conPars = np} = theDef def           -- if we are the the module that defines constructor x           -- then we have to drop at least the n module parameters-          n  <- getDefFreeVars x+          n <- getDefFreeVars x           -- the number of parameters is greater (if the data decl has           -- extra parameters) or equal (if not) to n           when (n > np) __IMPOSSIBLE__           let h = A.Con (unambiguous x)-          if null vs then return h else do-            es <- reify (map (fromMaybe __IMPOSSIBLE__ . isApplyElim) vs)-            -- Andreas, 2012-04-20: do not reify parameter arguments of constructor-            -- if the first regular constructor argument is hidden-            -- we turn it into a named argument, in order to avoid confusion-            -- with the parameter arguments which can be supplied in abstract syntax-            ---            -- Andreas, 2012-09-17: this does not remove all sources of confusion,-            -- since parameters could have the same name as regular arguments-            -- (see for example the parameter {i} to Data.Star.Star, which is also-            -- the first argument to the cons).-            -- @data Star {i}{I : Set i} ... where cons : {i :  I} ...@-            if np == 0 then apps h es else do-              -- Get name of first argument from type of constructor.-              -- Here, we need the reducing version of @telView@-              -- because target of constructor could be a definition-              -- expanding into a function type.  See test/succeed/NameFirstIfHidden.agda.-              TelV tel _ <- telView (defType def)-              let (pars, rest) = splitAt np $ telToList tel-              case rest of-                -- 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}) ->-                             -- setRelevance Relevant $-                             hideOrKeepInstance $ Arg ai underscore-                  apps h $ us ++ es  -- Note: unless --show-implicit, @apps@ will drop @us@.-                -- otherwise, we drop all parameters-                _ -> apps h es+          if null vs+            then return h+            else do+              es <- reify (map (fromMaybe __IMPOSSIBLE__ . isApplyElim) vs)+              -- Andreas, 2012-04-20: do not reify parameter arguments of constructor+              -- if the first regular constructor argument is hidden+              -- we turn it into a named argument, in order to avoid confusion+              -- with the parameter arguments which can be supplied in abstract syntax+              --+              -- Andreas, 2012-09-17: this does not remove all sources of confusion,+              -- since parameters could have the same name as regular arguments+              -- (see for example the parameter {i} to Data.Star.Star, which is also+              -- the first argument to the cons).+              -- @data Star {i}{I : Set i} ... where cons : {i :  I} ...@+              if np == 0+                then apps h es+                else do+                  -- Get name of first argument from type of constructor.+                  -- Here, we need the reducing version of @telView@+                  -- because target of constructor could be a definition+                  -- expanding into a function type.  See test/succeed/NameFirstIfHidden.agda.+                  TelV tel _ <- telView (defType def)+                  let (pars, rest) = splitAt np $ telToList tel+                  case rest of+                    -- 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}) ->+                            -- setRelevance Relevant $+                            hideOrKeepInstance $ Arg ai underscore+                      apps h $ us ++ es -- Note: unless --show-implicit, @apps@ will drop @us@.+                    -- otherwise, we drop all parameters+                    _ -> apps h es  --    I.Lam info b | isAbsurdBody b -> return $ A. AbsurdLam noExprInfo $ getHiding info     I.Lam info b    -> do       (x,e) <- reify b+      -- #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       -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda     I.Lit l        -> reify l@@ -528,12 +542,13 @@         mkPi b (Arg info a') = do           tac <- traverse reify $ domTactic a           (x, b) <- reify b-          return $ A.Pi noExprInfo [TBind noRange tac [Arg info $ Named (domName a) $ mkBinder_ x] a'] b+          let xs = singleton $ Arg info $ Named (domName a) $ mkBinder_ x+          return $ A.Pi noExprInfo (singleton $ TBind noRange tac xs a') b         -- We can omit the domain type if it doesn't have any free variables         -- and it's mentioned in the target type.         domainFree a b = do           df <- asksTC envPrintDomainFreePi-          return $ and [df, freeIn 0 b, closed a]+          return $ df && freeIn 0 b && closed a      I.Sort s     -> reify s     I.MetaV x es -> do@@ -549,6 +564,8 @@                                     <*> getContextTelescope                                     <*> viewTC (eCheckpoints . key local_chkpt)             (,,) <$> viewTC (eCheckpoints . key chkpt) <*> pure tel <*> pure msub2++          opt_show_ids <- showIdentitySubstitutions           let               addNames []    es = map (fmap unnamed) es               addNames _     [] = []@@ -579,7 +596,8 @@                      doDrop _         [] = []                  in doDrop dropArg $ named_es' -              simpl_named_es' | Just sub_mtel2local <- msub1 = dropIdentitySubs IdS           sub_mtel2local+              simpl_named_es' | opt_show_ids                 = named_es'+                              | Just sub_mtel2local <- msub1 = dropIdentitySubs IdS           sub_mtel2local                               | Just sub_local2mtel <- msub2 = dropIdentitySubs sub_local2mtel IdS                               | otherwise                    = named_es' @@ -589,7 +607,7 @@       showIrr <- optShowIrrelevant <$> pragmaOptions       if | showIrr   -> reifyTerm expandAnonDefs v          | otherwise -> return underscore-    I.Dummy s [] -> return $ A.Lit $ LitString noRange s+    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'@@ -639,16 +657,17 @@        -- Check if we have an absurd lambda.       case def of-       Function{ funCompiled = Just Fail, funClauses = [cl] }-                | isAbsurdLambdaName x -> do+       Function{ funCompiled = Just Fail{}, funClauses = [cl] }+          | isAbsurdLambdaName x -> do                   -- get hiding info from last pattern, which should be ()-                  let h = getHiding $ last $ namedClausePats cl-                      n = length (namedClausePats cl) - 1  -- drop all args before the absurd one+                  let (ps, p) = fromMaybe __IMPOSSIBLE__ $ initLast $ namedClausePats cl+                  let h = getHiding p+                      n = length ps  -- drop all args before the absurd one                       absLam = A.AbsurdLam exprNoRange h                   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) $ init $ namedClausePats cl+                            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)@@ -671,13 +690,14 @@          extLam <- case def of           Function{ funExtLam = Just{}, funProjection = Just{} } -> __IMPOSSIBLE__-          Function{ funExtLam = Just (ExtLamInfo m sys) } ->+          Function{ funExtLam = Just (ExtLamInfo m b sys) } ->             Just . (,Strict.toLazy sys) . size <$> lookupSection m           _ -> return Nothing         case extLam of-          Just (pars, sys) | df, notElem x alreadyPrinting ->+          Just (pars, sys) | df, x `notElem` alreadyPrinting ->             locallyTC ePrintingPatternLambdas (x :) $-            reifyExtLam x pars sys (defClauses defn) es+            reifyExtLam x (defArgInfo defn) pars sys+              (defClauses defn) es          -- Otherwise (ordinary function call):           _ -> do@@ -743,9 +763,9 @@             -- If it is not a projection(-like) function, we need no padding.             _ -> return ([], map (fmap unnamed) $ drop n es) -           reportS "reify.def" 70-             [ "  pad = " ++ show pad-             , "  nes = " ++ show nes+           reportSDoc "reify.def" 100 $ return $ vcat+             [ "  pad =" <+> pshow pad+             , "  nes =" <+> pshow nes              ]            let hd0 | isProperProjection def = A.Proj ProjPrefix $ AmbQ $ singleton x                    | otherwise = A.Def x@@ -759,20 +779,23 @@     -- them (plus the associated arguments to the extended lambda), we produce     -- something -    -- * that violates internal invariants.  In particular, the permutation-    --   dbPatPerm from the patterns to the telescope can no longer be-    --   computed.  (And in fact, dropping from the start of the telescope is-    --   just plainly unsound then.)+    -- i) that violates internal invariants.  In particular, the permutation+    -- dbPatPerm from the patterns to the telescope can no longer be+    -- computed.  (And in fact, dropping from the start of the telescope is+    -- just plainly unsound then.) -    -- * prints the wrong thing (old fix for #2047)+    -- ii) prints the wrong thing (old fix for #2047)      -- What we do now, is more sound, although not entirely satisfying:     -- When the "parameter" patterns of an external lambdas are not variable     -- patterns, we fall back to printing the internal function created for the     -- extended lambda, instead trying to construct the nice syntax. -    reifyExtLam :: MonadReify m => QName -> Int -> Maybe System -> [I.Clause] -> I.Elims -> m Expr-    reifyExtLam x npars msys cls es = do+    reifyExtLam+      :: MonadReify m+      => QName -> ArgInfo -> Int -> Maybe System -> [I.Clause]+      -> I.Elims -> m Expr+    reifyExtLam x i npars msys cls es = do       reportSLn "reify.def" 10 $ "reifying extended lambda " ++ prettyShow x       reportSLn "reify.def" 50 $ render $ nest 2 $ vcat         [ "npars =" <+> pretty npars@@ -789,9 +812,16 @@       cls <- caseMaybe msys                (mapM (reify . NamedClause x False . (`apply` pars)) cls)                (reify . QNamed x . (`apply` pars))-      let cx    = nameConcrete $ qnameName x-          dInfo = mkDefInfo cx noFixity' PublicAccess ConcreteDef (getRange x)-      elims (A.ExtendedLam exprNoRange dInfo x cls) =<< reify rest+      let cx     = nameConcrete $ qnameName x+          dInfo  = mkDefInfo cx noFixity' PublicAccess ConcreteDef+                     (getRange x)+          erased = case getQuantity i of+            Quantity0 o -> Erased o+            Quantityω o -> NotErased o+            Quantity1 o -> __IMPOSSIBLE__+      elims (A.ExtendedLam exprNoRange dInfo erased x $+             List1.fromList cls)+        =<< reify rest  -- | @nameFirstIfHidden (x:a) ({e} es) = {x = e} es@ nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)]@@ -801,12 +831,16 @@ nameFirstIfHidden _ es =   map (fmap unnamed) es -instance Reify i a => Reify (Named n i) (Named n a) where+instance Reify i => Reify (Named n i) where+  type ReifiesTo (Named n i) = Named n (ReifiesTo i)+   reify = traverse reify   reifyWhen b = traverse (reifyWhen b)  -- | Skip reification of implicit and irrelevant args if option is off.-instance (Reify i a) => Reify (Arg i) (Arg a) where+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 (getRelevance info /= Irrelevant) `or2M` showIrrelevantArguments)@@ -814,13 +848,13 @@  -- instance Reify Elim Expr where --   reifyWhen = reifyWhenE---   reify e = case e of+--   reify = \case --     I.IApply x y r -> appl "iapply" <$> reify (defaultArg r :: Arg Term) --     I.Apply v -> appl "apply" <$> reify v --     I.Proj f  -> appl "proj"  <$> reify ((defaultArg $ I.Def f []) :: Arg Term) --     where --       appl :: String -> Arg Expr -> Expr---       appl s v = A.App exprInfo (A.Lit (LitString noRange s)) $ fmap unnamed v+--       appl s v = A.App exprInfo (A.Lit empty (LitString s)) $ fmap unnamed v  data NamedClause = NamedClause QName Bool I.Clause   -- ^ Also tracks whether module parameters should be dropped from the patterns.@@ -837,7 +871,7 @@   mappend = (<>)  -- | Removes argument names.  Preserves names present in the source.-removeNameUnlessUserWritten :: (LensNamed n a, LensOrigin n) => a -> a+removeNameUnlessUserWritten :: (LensNamed a, LensOrigin (NameOf a)) => a -> a removeNameUnlessUserWritten a   | (getOrigin <$> getNameOf a) == Just UserWritten = a   | otherwise = setNameOf Nothing a@@ -850,13 +884,13 @@ stripImplicits params ps = do   -- if --show-implicit we don't need the names   ifM showImplicitArguments (return $ map (fmap removeNameUnlessUserWritten) ps) $ do-    reportS "reify.implicit" 30+    reportSDoc "reify.implicit" 100 $ return $ vcat       [ "stripping implicits"-      , "  ps   = " ++ show ps+      , nest 2 $ "ps   =" <+> pshow ps       ]     let ps' = blankDots $ strip ps-    reportS "reify.implicit" 30-      [ "  ps'  = " ++ show ps'+    reportSDoc "reify.implicit" 100 $ return $ vcat+      [ nest 2 $ "ps'  =" <+> pshow ps'       ]     return ps'     where@@ -895,20 +929,21 @@            stripArg a = fmap (fmap stripPat) a -          stripPat p = case p of-            A.VarP _      -> p-            A.ConP i c ps -> A.ConP i c $ stripArgs True ps-            A.ProjP{}     -> p-            A.DefP _ _ _  -> p-            A.DotP _ e    -> p-            A.WildP _     -> p-            A.AbsurdP _   -> p-            A.LitP _      -> p-            A.AsP i x p   -> A.AsP i x $ stripPat p-            A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p-            A.RecP i fs   -> A.RecP i $ map (fmap stripPat) fs  -- TODO Andreas: is this right?-            A.EqualP{}    -> p -- EqualP cannot be blanked.-            A.WithP i p   -> A.WithP i $ stripPat p -- TODO #2822: right?+          stripPat = \case+            p@(A.VarP _)        -> p+            A.ConP i c ps       -> A.ConP i c $ stripArgs True ps+            p@A.ProjP{}         -> p+            p@(A.DefP _ _ _)    -> p+            p@(A.DotP _ _e)     -> p+            p@(A.WildP _)       -> p+            p@(A.AbsurdP _)     -> p+            p@(A.LitP _ _)      -> p+            A.AsP i x p         -> A.AsP i x $ stripPat p+            A.PatternSynP _ _ _ -> __IMPOSSIBLE__+            A.RecP i fs         -> A.RecP 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?+            A.AnnP i a p        -> A.AnnP i a $ stripPat p            varOrDot A.VarP{}      = True           varOrDot A.WildP{}     = True@@ -936,11 +971,12 @@   default blank :: (Functor f, BlankVars b, f b ~ a) => Set Name -> a -> a   blank = fmap . blank -instance BlankVars a => BlankVars (Arg a)              where-instance BlankVars a => BlankVars (Named s a)          where-instance BlankVars a => BlankVars [a]                  where--- instance BlankVars a => BlankVars (A.Pattern' a)       where  -- see case EqualP !-instance BlankVars a => BlankVars (FieldAssignment' a) where+instance BlankVars a => BlankVars (Arg a)+instance BlankVars a => BlankVars (Named s a)+instance BlankVars a => BlankVars [a]+instance BlankVars a => BlankVars (List1 a)+instance BlankVars a => BlankVars (FieldAssignment' a)+-- instance BlankVars a => BlankVars (A.Pattern' a)         -- see case EqualP !  instance (BlankVars a, BlankVars b) => BlankVars (a, b) where   blank bound (x, y) = (blank bound x, blank bound y)@@ -953,12 +989,13 @@   blank bound = id  instance BlankVars A.Clause where-  blank bound (A.Clause lhs strippedPats rhs (A.WhereDecls _ []) ca) =-    let bound' = varsBoundIn lhs `Set.union` bound-    in  A.Clause (blank bound' lhs)+  blank bound (A.Clause lhs strippedPats rhs wh ca)+    | null wh =+        A.Clause (blank bound' lhs)                  (blank bound' strippedPats)                  (blank bound' rhs) noWhereDecls ca-  blank bound (A.Clause lhs strippedPats rhs _ ca) = __IMPOSSIBLE__+    | otherwise = __IMPOSSIBLE__+    where bound' = varsBoundIn lhs `Set.union` bound  instance BlankVars A.LHS where   blank bound (A.LHS i core) = A.LHS i $ blank bound core@@ -977,48 +1014,47 @@     A.DotP i e    -> A.DotP i $ blank bound e     A.WildP _     -> p     A.AbsurdP _   -> p-    A.LitP _      -> p+    A.LitP _ _    -> p     A.AsP i n p   -> A.AsP i n $ blank bound p     A.PatternSynP _ _ _ -> __IMPOSSIBLE__     A.RecP i fs   -> A.RecP i $ blank bound fs     A.EqualP{}    -> p     A.WithP i p   -> A.WithP i (blank bound p)+    A.AnnP i a p  -> A.AnnP i (blank bound a) (blank bound p)  instance BlankVars A.Expr where   blank bound e = case e of-    A.ScopedExpr i e       -> A.ScopedExpr i $ blank bound e-    A.Var x                -> if x `Set.member` bound then e-                              else A.Underscore emptyMetaInfo  -- Here is the action!-    A.Def _                -> e-    A.Proj{}               -> e-    A.Con _                -> e-    A.Lit _                -> e-    A.QuestionMark{}       -> e-    A.Underscore _         -> e-    A.Dot i e              -> A.Dot i $ blank bound e-    A.App i e1 e2          -> uncurry (A.App i) $ blank bound (e1, e2)-    A.WithApp i e es       -> uncurry (A.WithApp i) $ blank bound (e, es)-    A.Lam i b e            -> let bound' = varsBoundIn b `Set.union` bound-                              in  A.Lam i (blank bound b) (blank bound' e)-    A.AbsurdLam _ _        -> e-    A.ExtendedLam i d f cs -> A.ExtendedLam i d f $ blank bound cs-    A.Pi i tel e           -> let bound' = varsBoundIn tel `Set.union` bound-                              in  uncurry (A.Pi i) $ blank bound' (tel, e)-    A.Generalized {}       -> __IMPOSSIBLE__-    A.Fun i a b            -> uncurry (A.Fun i) $ blank bound (a, b)-    A.Set _ _              -> e-    A.Prop _ _             -> e-    A.Let _ _ _            -> __IMPOSSIBLE__-    A.Rec i es             -> A.Rec i $ blank bound es-    A.RecUpdate i e es     -> uncurry (A.RecUpdate i) $ blank bound (e, es)-    A.ETel _               -> __IMPOSSIBLE__-    A.Quote {}             -> __IMPOSSIBLE__-    A.QuoteTerm {}         -> __IMPOSSIBLE__-    A.Unquote {}           -> __IMPOSSIBLE__-    A.Tactic {}            -> __IMPOSSIBLE__-    A.DontCare v           -> A.DontCare $ blank bound v-    A.PatternSyn {}        -> e-    A.Macro {}             -> e+    A.ScopedExpr i e         -> A.ScopedExpr i $ blank bound e+    A.Var x                  -> if x `Set.member` bound then e+                                else A.Underscore emptyMetaInfo  -- Here is the action!+    A.Def' _ _               -> e+    A.Proj{}                 -> e+    A.Con _                  -> e+    A.Lit _ _                -> e+    A.QuestionMark{}         -> e+    A.Underscore _           -> e+    A.Dot i e                -> A.Dot i $ blank bound e+    A.App i e1 e2            -> uncurry (A.App i) $ blank bound (e1, e2)+    A.WithApp i e es         -> uncurry (A.WithApp i) $ blank bound (e, es)+    A.Lam i b e              -> let bound' = varsBoundIn b `Set.union` bound+                                in  A.Lam i (blank bound b) (blank bound' e)+    A.AbsurdLam _ _          -> e+    A.ExtendedLam i d e f cs -> A.ExtendedLam i d e f $ blank bound cs+    A.Pi i tel e             -> let bound' = varsBoundIn tel `Set.union` bound+                                in  uncurry (A.Pi i) $ blank bound' (tel, e)+    A.Generalized {}         -> __IMPOSSIBLE__+    A.Fun i a b              -> uncurry (A.Fun i) $ blank bound (a, b)+    A.Let _ _ _              -> __IMPOSSIBLE__+    A.Rec i es               -> A.Rec i $ blank bound es+    A.RecUpdate i e es       -> uncurry (A.RecUpdate i) $ blank bound (e, es)+    A.ETel _                 -> __IMPOSSIBLE__+    A.Quote {}               -> __IMPOSSIBLE__+    A.QuoteTerm {}           -> __IMPOSSIBLE__+    A.Unquote {}             -> __IMPOSSIBLE__+    A.Tactic {}              -> __IMPOSSIBLE__+    A.DontCare v             -> A.DontCare $ blank bound v+    A.PatternSyn {}          -> e+    A.Macro {}               -> e  instance BlankVars A.ModuleName where   blank bound = id@@ -1069,6 +1105,7 @@     A.RecP _ _          -> empty     A.EqualP{}          -> empty     A.WithP _ _         -> empty+    A.AnnP{}            -> empty  instance Binder a => Binder (A.Binder' a) where   varsBoundIn (A.Binder p n) = varsBoundIn (p, n)@@ -1091,11 +1128,12 @@   varsBoundIn LetOpen{}           = empty   varsBoundIn LetDeclaredVariable{} = empty -instance Binder a => Binder (FieldAssignment' a) where-instance Binder a => Binder (Arg a)              where-instance Binder a => Binder (Named x a)          where-instance Binder a => Binder [a]                  where-instance Binder a => Binder (Maybe a)            where+instance Binder a => Binder (FieldAssignment' a)+instance Binder a => Binder (Arg a)+instance Binder a => Binder (Named x a)+instance Binder a => Binder [a]+instance Binder a => Binder (List1 a)+instance Binder a => Binder (Maybe a)  instance (Binder a, Binder b) => Binder (a, b) where   varsBoundIn (x, y) = varsBoundIn x `Set.union` varsBoundIn y@@ -1121,13 +1159,13 @@      reifyPat :: MonadReify m => I.DeBruijnPattern -> m A.Pattern     reifyPat p = do-     reportSLn "reify.pat" 80 $ "reifying pattern " ++ show p+     reportSDoc "reify.pat" 80 $ return $ "reifying pattern" <+> pretty p      keepVars <- optKeepPatternVariables <$> pragmaOptions      case p of       -- Possibly expanded literal pattern (see #4215)       p | Just (PatternInfo PatOLit asB) <- patternInfo p -> do         reduce (I.patternToTerm p) >>= \case-          I.Lit l -> addAsBindings asB $ return $ A.LitP l+          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@@ -1145,7 +1183,7 @@           else             reifyDotP o v         o -> reifyDotP o v-      I.LitP i l  -> addAsBindings (patAsNames i) $ return $ A.LitP l+      I.LitP i l  -> addAsBindings (patAsNames 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@@ -1177,14 +1215,13 @@            -- Andreas, 2017-09-03, issue #2729            -- Restore original pattern name.  AbstractToConcrete picks unique names.          | otherwise -> return $ A.VarP $-             mkBindName n { nameConcrete = C.Name noRange C.InScope [ C.Id y ] }+             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-         | otherwise      -> A.DotP patNoRange <$> reify v+      if | PatOVar x <- o , keepVars       -> return $ A.VarP $ mkBindName x+         | otherwise                       -> A.DotP patNoRange <$> reify v      reifyConP :: MonadReify m               => ConHead -> ConPatternInfo -> [NamedArg DeBruijnPattern]@@ -1209,6 +1246,7 @@   let fallback = return p   case p of     A.ConP ci c ps -> do+        reportSLn "reify.pat" 60 $ "tryRecPFromConP " ++ prettyShow 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.@@ -1221,15 +1259,39 @@           mkFA ax nap = FieldAssignment (unDom ax) (namedArg nap)     _ -> __IMPOSSIBLE__ -instance Reify (QNamed I.Clause) A.Clause where+-- | 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+  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+      fs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r+      unless (length fs == length es) __IMPOSSIBLE__+      return $ A.Rec empty $ zipWith mkFA fs 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+   reify (QNamed f cl) = reify (NamedClause f True cl) -instance Reify NamedClause A.Clause where+instance Reify NamedClause where+  type ReifiesTo NamedClause = A.Clause+   reify (NamedClause f toDrop cl) = addContext (clauseTel cl) $ do-    reportSLn "reify.clause" 60 $ "reifying NamedClause"-      ++ "\n  f      = " ++ prettyShow f-      ++ "\n  toDrop = " ++ show toDrop-      ++ "\n  cl     = " ++ show cl+    reportSDoc "reify.clause" 60 $ return $ vcat+      [ "reifying NamedClause"+      , "  f      =" <+> pretty f+      , "  toDrop =" <+> pshow toDrop+      , "  cl     =" <+> pretty cl+      ]     let ell = clauseEllipsis cl     ps  <- reifyPatterns $ namedClausePats cl     lhs <- uncurry (SpineLHS $ empty { lhsEllipsis = ell }) <$> reifyDisplayFormP f ps []@@ -1243,12 +1305,12 @@         Right m -> size <$> lookupSection m       return $ splitParams nfv lhs     lhs <- stripImps params lhs-    reportSLn "reify.clause" 60 $ "reifying NamedClause, lhs = " ++ show lhs+    reportSDoc "reify.clause" 100 $ return $ "reifying NamedClause, lhs =" <?> pshow lhs     rhs <- caseMaybe (clauseBody cl) (return AbsurdRHS) $ \ e ->       RHS <$> reify e <*> pure Nothing-    reportSLn "reify.clause" 60 $ "reifying NamedClause, rhs = " ++ show rhs+    reportSDoc "reify.clause" 100 $ return $ "reifying NamedClause, rhs =" <?> pshow rhs     let result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls (I.clauseCatchall cl)-    reportSLn "reify.clause" 60 $ "reified NamedClause, result = " ++ show result+    reportSDoc "reify.clause" 100 $ return $ "reified NamedClause, result =" <?> pshow result     return result     where       splitParams n (SpineLHS i f ps) =@@ -1257,7 +1319,9 @@       stripImps :: MonadReify m => [NamedArg A.Pattern] -> SpineLHS -> m SpineLHS       stripImps params (SpineLHS i f ps) =  SpineLHS i f <$> stripImplicits params ps -instance Reify (QNamed System) [A.Clause] where+instance Reify (QNamed System) where+  type ReifiesTo (QNamed System) = [A.Clause]+   reify (QNamed f (System tel sys)) = addContext tel $ do     reportS "reify.system" 40 $ show tel : map show sys     view <- intervalView'@@ -1284,32 +1348,45 @@         result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls False       return result -instance Reify Type Expr where+instance Reify Type where+    type ReifiesTo Type = Expr+     reifyWhen = reifyWhenE     reify (I.El _ t) = reify t -instance Reify Sort Expr where+instance Reify Sort where+    type ReifiesTo Sort = Expr+     reifyWhen = reifyWhenE     reify s = do       s <- instantiateFull s+      SortKit{..} <- sortKit       case s of-        I.Type (I.ClosedLevel n) -> return $ A.Set noExprInfo n+        I.Type (I.ClosedLevel 0) -> return $ A.Def' nameOfSet A.NoSuffix+        I.Type (I.ClosedLevel n) -> return $ A.Def' nameOfSet (A.Suffix n)         I.Type a -> do           a <- reify a-          return $ A.App defaultAppInfo_ (A.Set noExprInfo 0) (defaultNamedArg a)-        I.Prop (I.ClosedLevel n) -> return $ A.Prop noExprInfo n+          return $ A.App defaultAppInfo_ (A.Def nameOfSet) (defaultNamedArg a)+        I.Prop (I.ClosedLevel 0) -> return $ A.Def' nameOfProp A.NoSuffix+        I.Prop (I.ClosedLevel n) -> return $ A.Def' nameOfProp (A.Suffix n)         I.Prop a -> do           a <- reify a-          return $ A.App defaultAppInfo_ (A.Prop noExprInfo 0) (defaultNamedArg a)-        I.Inf       -> do-          I.Def inf [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega-          return $ A.Def inf+          return $ A.App defaultAppInfo_ (A.Def nameOfProp) (defaultNamedArg a)+        I.Inf f 0 -> return $ A.Def' (nameOfSetOmega f) A.NoSuffix+        I.Inf f n -> return $ A.Def' (nameOfSetOmega f) (A.Suffix n)+        I.SSet a  -> do+          I.Def sset [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet+          a <- reify a+          return $ A.App defaultAppInfo_ (A.Def sset) (defaultNamedArg a)         I.SizeUniv  -> do           I.Def sizeU [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeUniv           return $ A.Def sizeU-        I.PiSort a s -> do+        I.LockUniv  -> do+          lockU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLockUniv+          return $ A.Def lockU+        I.PiSort a s1 s2 -> do           pis <- freshName_ ("piSort" :: String) -- TODO: hack-          (e1,e2) <- reify (getSort a, I.Lam defaultArgInfo $ fmap Sort s)+          (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         I.FunSort s1 s2 -> do@@ -1323,9 +1400,11 @@           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 $ LitString noRange s+        I.DummyS s -> return $ A.Lit empty $ LitString $ T.pack s -instance Reify Level Expr where+instance Reify Level where+  type ReifiesTo Level = Expr+   reifyWhen = reifyWhenE   reify l   = ifM haveLevels (reify =<< reallyUnLevelView l) $ {-else-} do     -- Andreas, 2017-09-18, issue #2754@@ -1334,7 +1413,9 @@     name <- freshName_ (".#Lacking_Level_Builtins#" :: String)     return $ A.Var name -instance (Free i, Reify i a) => Reify (Abs i) (Name, a) where+instance (Free i, Reify i) => Reify (Abs i) where+  type ReifiesTo (Abs i) = (Name, ReifiesTo i)+   reify (NoAbs x v) = freshName_ x >>= \name -> (name,) <$> reify v   reify (Abs s v) = do @@ -1347,7 +1428,9 @@          $ reify v     return (x,e) -instance Reify I.Telescope A.Telescope where+instance Reify I.Telescope where+  type ReifiesTo I.Telescope = A.Telescope+   reify EmptyTel = return []   reify (ExtendTel arg tel) = do     Arg info e <- reify arg@@ -1355,24 +1438,34 @@     let r    = getRange e         name = domName arg     tac <- traverse reify $ domTactic arg-    return $ TBind r tac [Arg info $ Named name $ A.mkBinder_ x] e : bs+    let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x+    return $ TBind r tac xs e : bs -instance Reify i a => Reify (Dom i) (Arg a) where+instance Reify i => Reify (Dom i) where+    type ReifiesTo (Dom i) = Arg (ReifiesTo i)+     reify (Dom{domInfo = info, unDom = i}) = Arg info <$> reify i -instance Reify i a => Reify (I.Elim' i) (I.Elim' a) where+instance Reify i => Reify (I.Elim' i)  where+  type ReifiesTo (I.Elim' i) = I.Elim' (ReifiesTo i)+   reify = traverse reify   reifyWhen b = traverse (reifyWhen b) -instance Reify i a => Reify [i] [a] where+instance Reify i => Reify [i] where+  type ReifiesTo [i] = [ReifiesTo i]+   reify = traverse reify   reifyWhen b = traverse (reifyWhen b) -instance (Reify i1 a1, Reify i2 a2) => Reify (i1,i2) (a1,a2) where+instance (Reify i1, Reify i2) => Reify (i1, i2) where+    type ReifiesTo (i1, i2) = (ReifiesTo i1, ReifiesTo i2)     reify (x,y) = (,) <$> reify x <*> reify y -instance (Reify i1 a1, Reify i2 a2, Reify i3 a3) => Reify (i1,i2,i3) (a1,a2,a3) where+instance (Reify i1, Reify i2, Reify i3) => Reify (i1,i2,i3) where+    type ReifiesTo (i1, i2, i3) = (ReifiesTo i1, ReifiesTo i2, ReifiesTo i3)     reify (x,y,z) = (,,) <$> reify x <*> reify y <*> reify z -instance (Reify i1 a1, Reify i2 a2, Reify i3 a3, Reify i4 a4) => Reify (i1,i2,i3,i4) (a1,a2,a3,a4) where+instance (Reify i1, Reify i2, Reify i3, Reify i4) => Reify (i1,i2,i3,i4) where+    type ReifiesTo (i1, i2, i3, i4) = (ReifiesTo i1, ReifiesTo i2, ReifiesTo i3, ReifiesTo i4)     reify (x,y,z,w) = (,,,) <$> reify x <*> reify y <*> reify z <*> reify w

src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs view

@@ -1,12 +1,17 @@-{-# LANGUAGE UndecidableInstances #-}- {-# OPTIONS_GHC -fwarn-missing-signatures #-}  module Agda.Syntax.Translation.ReflectedToAbstract where +import Control.Arrow ( (***) )+import Control.Monad.Except import Control.Monad.Reader -import Agda.Syntax.Fixity+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+ import Agda.Syntax.Literal import Agda.Syntax.Position import Agda.Syntax.Info@@ -16,84 +21,126 @@ import Agda.Syntax.Reflected as R import Agda.Syntax.Internal (Dom,Dom'(..)) +import Agda.Interaction.Options (optUseUnicode, UnicodeOrAscii(..)) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.Syntax.Scope.Monad (getCurrentModule) -import Agda.Utils.Except+import Agda.Utils.Impossible+import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null+import Agda.Utils.Pretty import Agda.Utils.Functor+import Agda.Utils.Singleton import Agda.Utils.Size -type Names = [Name]+type Vars = [(Name,R.Type)]  type MonadReflectedToAbstract m =-  ( MonadReader Names m+  ( MonadReader Vars m   , MonadFresh NameId m   , MonadError TCErr m   , MonadTCEnv m   , ReadTCState m   , HasOptions m+  , HasBuiltins m   , HasConstInfo m   )  -- | Adds a new unique name to the current context.+--   NOTE: See @chooseName@ in @Agda.Syntax.Translation.AbstractToConcrete@ for similar logic.+--   NOTE: See @freshConcreteName@ in @Agda.Syntax.Scope.Monad@ also for similar logic. withName :: MonadReflectedToAbstract m => String -> (Name -> m a) -> m a-withName s f = do+withName s = withVar s R.Unknown++withVar :: MonadReflectedToAbstract m => String -> R.Type -> (Name -> m a) -> m a+withVar s t f = do   name <- freshName_ s-  ctx  <- asks $ map nameConcrete-  let name' = head $ filter (notTaken ctx) $ iterate nextName name-  local (name:) $ f name'+  ctx  <- asks $ map $ nameConcrete . fst+  glyphMode <- optUseUnicode <$> M.pragmaOptions+  let freshNameMode = case glyphMode of+        UnicodeOk -> A.UnicodeSubscript+        AsciiOnly -> A.AsciiCounter+  let name' = head $ filter (notTaken ctx) $ iterate (nextName freshNameMode) name+  local ((name,t):) $ f name'   where     notTaken xs x = isNoName x || nameConcrete x `notElem` xs --- | Returns the name of the variable with the given de Bruijn index.+withNames :: MonadReflectedToAbstract m => [String] -> ([Name] -> m a) -> m a+withNames ss = withVars $ zip ss $ repeat R.Unknown++withVars :: MonadReflectedToAbstract m => [(String, R.Type)] -> ([Name] -> m a) -> m a+withVars ss f = case ss of+  []     -> f []+  ((s,t):ss) -> withVar s t $ \n -> withVars ss $ \ns -> f (n:ns)++-- | Returns the name and type of the variable with the given de Bruijn index.+askVar :: MonadReflectedToAbstract m => Int -> m (Maybe (Name,R.Type))+askVar i = reader (!!! i)+ askName :: MonadReflectedToAbstract m => Int -> m (Maybe Name)-askName i = reader (!!! i)+askName i = fmap fst <$> askVar i -class ToAbstract r a | r -> a where-  toAbstract :: MonadReflectedToAbstract m => r -> m a+class ToAbstract r where+  type AbsOfRef r+  toAbstract :: MonadReflectedToAbstract m => r -> m (AbsOfRef r) +  default toAbstract+    :: (Traversable t, ToAbstract s, t s ~ r, t (AbsOfRef s) ~ (AbsOfRef r))+    => MonadReflectedToAbstract m => r -> m (AbsOfRef r)+  toAbstract = traverse toAbstract+ -- | Translate reflected syntax to abstract, using the names from the current typechecking context. toAbstract_ ::-  (ToAbstract r a+  (ToAbstract r   , MonadFresh NameId m   , MonadError TCErr m   , MonadTCEnv m   , ReadTCState m   , HasOptions m+  , HasBuiltins m   , HasConstInfo m-  ) => r -> m a+  ) => r -> m (AbsOfRef r) toAbstract_ = withShowAllArguments . toAbstractWithoutImplicit  -- | Drop implicit arguments unless --show-implicit is on. toAbstractWithoutImplicit ::-  (ToAbstract r a+  (ToAbstract r   , MonadFresh NameId m   , MonadError TCErr m   , MonadTCEnv m   , ReadTCState m   , HasOptions m+  , HasBuiltins m   , HasConstInfo m-  ) => r -> m a-toAbstractWithoutImplicit x = runReaderT (toAbstract x) =<< getContextNames+  ) => r -> m (AbsOfRef r)+toAbstractWithoutImplicit x = do+  xs <- getContextNames+  let ctx = zip xs $ repeat R.Unknown+  runReaderT (toAbstract x) ctx -instance ToAbstract r a => ToAbstract (Named name r) (Named name a) where-  toAbstract = traverse toAbstract+instance ToAbstract r => ToAbstract (Named name r) where+  type AbsOfRef (Named name r) = Named name (AbsOfRef r) -instance ToAbstract r a => ToAbstract (Arg r) (NamedArg a) where+instance ToAbstract r => ToAbstract (Arg r) where+  type AbsOfRef (Arg r) = NamedArg (AbsOfRef r)   toAbstract (Arg i x) = Arg i <$> toAbstract (unnamed x) -instance ToAbstract [Arg Term] [NamedArg Expr] where-  toAbstract = traverse toAbstract+instance ToAbstract r => ToAbstract [Arg r] where+  type AbsOfRef [Arg r] = [NamedArg (AbsOfRef r)] -instance ToAbstract r Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where+-- instance ToAbstract r Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where+instance (ToAbstract r, AbsOfRef r ~ Expr) => ToAbstract (Dom r, Name) where+  type AbsOfRef (Dom r, Name) = A.TypedBinding   toAbstract (Dom{domInfo = i,unDom = x, domTactic = tac}, name) = do     dom <- toAbstract x-    return $ mkTBind noRange [unnamedArg i $ mkBinder_ name] dom+    return $ mkTBind noRange (singleton $ unnamedArg i $ mkBinder_ name) dom -instance ToAbstract (Expr, Elim) Expr where+instance ToAbstract (Expr, Elim) where+  type AbsOfRef (Expr, Elim) = Expr   toAbstract (f, Apply arg) = do     arg     <- toAbstract arg     showImp <- showImplicitArguments@@ -101,26 +148,25 @@              then App (setOrigin Reflected defaultAppInfo_) f arg              else f -instance ToAbstract (Expr, Elims) Expr where+instance ToAbstract (Expr, Elims) where+  type AbsOfRef (Expr, Elims) = Expr   toAbstract (f, elims) = foldM (curry toAbstract) f elims -instance ToAbstract r a => ToAbstract (R.Abs r) (a, Name) where+instance ToAbstract r => ToAbstract (R.Abs r) where+  type AbsOfRef (R.Abs r) = (AbsOfRef r, Name)   toAbstract (Abs s x) = withName s' $ \name -> (,) <$> toAbstract x <*> return name     where s' = if (isNoName s) then "z" else s -- TODO: only do this when var is free -instance ToAbstract Literal Expr where-  toAbstract l = return (A.Lit l)+instance ToAbstract Literal where+  type AbsOfRef Literal = Expr+  toAbstract l = return $ A.Lit empty l -instance ToAbstract Term Expr where-  toAbstract t = case t of+instance ToAbstract Term where+  type AbsOfRef Term = Expr+  toAbstract = \case     R.Var i es -> do-      mname <- askName i-      case mname of-        Nothing -> do-          cxt   <- getContextTelescope-          names <- asks $ drop (size cxt) . reverse-          withShowAllArguments' False $ typeError $ DeBruijnIndexOutOfScope i cxt names-        Just name -> toAbstract (A.Var name, es)+      name <- mkVarName i+      toAbstract (A.Var name, es)     R.Con c es -> toAbstract (A.Con (unambiguous $ killRange c), es)     R.Def f es -> do       af <- mkDef (killRange f)@@ -135,12 +181,13 @@       let qname   = qualify m name           cname   = nameConcrete name           defInfo = mkDefInfo cname noFixity' PublicAccess ConcreteDef noRange-      cs <- toAbstract $ map (QNamed qname) cs-      toAbstract (A.ExtendedLam exprNoRange defInfo qname cs, es)+      cs <- toAbstract $ fmap (QNamed qname) cs+      toAbstract+        (A.ExtendedLam exprNoRange defInfo defaultErased qname cs, es)     R.Pi a b   -> do       (b, name) <- toAbstract b       a         <- toAbstract (a, name)-      return $ A.Pi exprNoRange [a] b+      return $ A.Pi exprNoRange (singleton a) b     R.Sort s   -> toAbstract s     R.Lit l    -> toAbstract l     R.Meta x es    -> toAbstract (A.Underscore info, es)@@ -153,47 +200,99 @@       (return $ A.Macro f)       (return $ A.Def f) -mkSet :: Expr -> Expr-mkSet e = App (setOrigin Reflected defaultAppInfo_) (A.Set exprNoRange 0) $ defaultNamedArg e+mkApp :: Expr -> Expr -> Expr+mkApp e1 e2 = App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2 -instance ToAbstract Sort Expr where-  toAbstract (SetS x) = mkSet <$> toAbstract x-  toAbstract (LitS x) = return $ A.Set exprNoRange x-  toAbstract UnknownS = return $ mkSet $ Underscore emptyMetaInfo -instance ToAbstract R.Pattern (Names, A.Pattern) where+mkVar :: MonadReflectedToAbstract m => Int -> m (Name, R.Type)+mkVar i = ifJustM (askVar i) return $ do+  cxt   <- getContextTelescope+  names <- asks $ drop (size cxt) . reverse . map fst+  withShowAllArguments' False $ typeError $ DeBruijnIndexOutOfScope i cxt names++mkVarName :: MonadReflectedToAbstract m => Int -> m Name+mkVarName i = fst <$> mkVar i++annotatePattern :: MonadReflectedToAbstract m => Int -> R.Type -> A.Pattern -> m A.Pattern+annotatePattern _ R.Unknown p = return p+annotatePattern i t p = local (drop $ i + 1) $ do+  t <- toAbstract t  -- go into the right context for translating the type+  return $ A.AnnP patNoRange t p++instance ToAbstract Sort where+  type AbsOfRef Sort = Expr+  toAbstract s = do+    setName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+    propName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinProp+    infName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSetOmega+    case s of+      SetS x -> mkApp (A.Def setName) <$> toAbstract x+      LitS x -> return $ A.Def' setName $ A.Suffix x+      PropS x -> mkApp (A.Def propName) <$> toAbstract x+      PropLitS x -> return $ A.Def' propName $ A.Suffix x+      InfS x -> return $ A.Def' infName $ A.Suffix x+      UnknownS -> return $ mkApp (A.Def setName) $ Underscore emptyMetaInfo++instance ToAbstract R.Pattern where+  type AbsOfRef R.Pattern = A.Pattern   toAbstract pat = case pat of     R.ConP c args -> do-      (names, args) <- toAbstractPats args-      return (names, A.ConP (ConPatInfo ConOCon patNoRange ConPatEager) (unambiguous $ killRange c) args)-    R.DotP    -> return ([], A.WildP patNoRange)-    R.VarP s | isNoName s -> withName "z" $ \ name -> return ([name], A.VarP $ mkBindName name)-        -- Ulf, 2016-08-09: Also bind noNames (#2129). This to make the-        -- behaviour consistent with lambda and pi.-        -- return ([], A.WildP patNoRange)-    R.VarP s  -> withName s $ \ name -> return ([name], A.VarP $ mkBindName name)-    R.LitP l  -> return ([], A.LitP l)-    R.AbsurdP -> return ([], A.AbsurdP patNoRange)-    R.ProjP d -> return ([], A.ProjP patNoRange ProjSystem $ unambiguous $ killRange d)+      args <- toAbstract args+      return $ A.ConP (ConPatInfo ConOCon patNoRange ConPatEager) (unambiguous $ killRange c) args+    R.DotP t -> A.DotP patNoRange <$> toAbstract t+    R.VarP i -> do+      (x, t) <- mkVar i+      annotatePattern i t $ A.VarP $ mkBindName x+    R.LitP l  -> return $ A.LitP patNoRange l+    R.AbsurdP i -> do+      (_, t) <- mkVar i+      annotatePattern i t $ A.AbsurdP patNoRange+    R.ProjP d -> return $ A.ProjP patNoRange ProjSystem $ unambiguous $ killRange d -toAbstractPats :: MonadReflectedToAbstract m => [Arg R.Pattern] -> m (Names, [NamedArg A.Pattern])-toAbstractPats pats = case pats of-    []   -> return ([], [])-    p:ps -> do-      (names,  p)  <- (distributeF . fmap distributeF) <$> toAbstract p-      (namess, ps) <- local (names++) $ toAbstractPats ps-      return (namess++names, p:ps)+instance ToAbstract (QNamed R.Clause) where+  type AbsOfRef (QNamed R.Clause) = A.Clause -instance ToAbstract (QNamed R.Clause) A.Clause where-  toAbstract (QNamed name (R.Clause pats rhs)) = do-    (names, pats) <- toAbstractPats pats-    rhs           <- local (names++) $ toAbstract rhs+  toAbstract (QNamed name (R.Clause tel pats rhs)) = withVars (map (Text.unpack *** unArg) tel) $ \_ -> do+    checkClauseTelescopeBindings tel pats+    pats <- toAbstract pats+    rhs  <- toAbstract rhs     let lhs = spineToLhs $ SpineLHS empty name pats     return $ A.Clause lhs [] (RHS rhs Nothing) noWhereDecls False-  toAbstract (QNamed name (R.AbsurdClause pats)) = do-    (_, pats) <- toAbstractPats pats+  toAbstract (QNamed name (R.AbsurdClause tel pats)) = withVars (map (Text.unpack *** unArg) tel) $ \_ -> do+    checkClauseTelescopeBindings tel pats+    pats <- toAbstract pats     let lhs = spineToLhs $ SpineLHS empty name pats     return $ A.Clause lhs [] AbsurdRHS noWhereDecls False -instance ToAbstract [QNamed R.Clause] [A.Clause] where+instance ToAbstract [QNamed R.Clause] where+  type AbsOfRef [QNamed R.Clause] = [A.Clause]   toAbstract = traverse toAbstract++instance ToAbstract (List1 (QNamed R.Clause)) where+  type AbsOfRef (List1 (QNamed R.Clause)) = List1 A.Clause+  toAbstract = traverse toAbstract++-- | Check that all variables in the telescope are bound in the left-hand side. Since we check the+--   telescope by attaching type annotations to the pattern variables there needs to be somewhere to+--   put the annotation. Also, since the lhs is where the variables are actually bound, missing a+--   binding for a variable that's used later in the telescope causes unbound variable panic+--   (see #5044).+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 $ ("Missing bindings for telescope variable" <> s) <?>+                              (fsep (punctuate ", " $ map (text . Text.unpack) xs) <> ".") $$+                             "All variables in the clause telescope must be bound in the left-hand side."+      where s | length xs == 1 = empty+              | otherwise      = "s"+  where+    bs = boundVars pats++    boundVars = Set.unions . map (bound . unArg)+    bound (R.VarP i)    = Set.singleton i+    bound (R.ConP _ ps) = boundVars ps+    bound R.DotP{}      = Set.empty+    bound R.LitP{}      = Set.empty+    bound (R.AbsurdP i) = Set.singleton i+    bound R.ProjP{}     = Set.empty

src/full/Agda/Syntax/Treeless.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternSynonyms #-}  -- | The treeless syntax is intended to be used as input for the compiler backends.@@ -13,19 +12,31 @@     ) where  import Control.Arrow (first, second)+import Control.DeepSeq  import Data.Data (Data) import Data.Word +import GHC.Generics (Generic)+ import Agda.Syntax.Position import Agda.Syntax.Literal+import Agda.Syntax.Common import Agda.Syntax.Abstract.Name  data Compiled = Compiled   { cTreeless :: TTerm-  , cArgUsage :: [Bool] }-  deriving (Data, Show, Eq, Ord)+  , cArgUsage :: Maybe [ArgUsage]+      -- ^ 'Nothing' if treeless usage analysis has not run yet.+  }+  deriving (Data, Show, Eq, Ord, Generic) +-- | Usage status of function arguments in treeless code.+data ArgUsage+  = ArgUsed+  | ArgUnused+  deriving (Data, 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.@@ -61,7 +72,7 @@            | TCoerce TTerm  -- ^ Used by the GHC backend            | TError TError            -- ^ A runtime error, something bad has happened.-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  -- | Compiler-related primitives. This are NOT the same thing as primitives -- in Agda's surface or internal syntax!@@ -89,7 +100,7 @@   | PIf   | PSeq   | PITo64 | P64ToI-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  isPrimEq :: TPrim -> Bool isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ, PEq64]@@ -140,14 +151,14 @@ mkLet x body = TLet x body  tInt :: Integer -> TTerm-tInt = TLit . LitNat noRange+tInt = TLit . LitNat  intView :: TTerm -> Maybe Integer-intView (TLit (LitNat _ x)) = Just x+intView (TLit (LitNat x)) = Just x intView _ = Nothing  word64View :: TTerm -> Maybe Word64-word64View (TLit (LitWord64 _ x)) = Just x+word64View (TLit (LitWord64 x)) = Just x word64View _ = Nothing  tPlusK :: Integer -> TTerm -> TTerm@@ -184,19 +195,21 @@ tIfThenElse c i e = TApp (TPrim PIf) [c, i, e]  data CaseType-  = CTData QName -- case on datatype+  = CTData Quantity QName+    -- Case on datatype. The 'Quantity' is zero for matches on erased+    -- arguments.   | CTNat   | CTInt   | CTChar   | CTString   | CTFloat   | CTQName-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  data CaseInfo = CaseInfo   { caseLazy :: Bool   , caseType :: CaseType }-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  data TAlt   = TACon    { aCon  :: QName, aArity :: Int, aBody :: TTerm }@@ -206,7 +219,7 @@   | TAGuard  { aGuard :: TTerm, aBody :: TTerm }   -- ^ Binds no variables   | TALit    { aLit :: Literal,   aBody:: TTerm }-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  data TError   = TUnreachable@@ -214,7 +227,11 @@   -- Runtime behaviour of unreachable code is undefined, but preferably   -- the program will exit with an error message. The compiler is free   -- to assume that this code is unreachable and to remove it.-  deriving (Data, Show, Eq, Ord)+  | TMeta String+  -- ^ Code which could not be obtained because of a hole in the program.+  -- This should throw a runtime error.+  -- The string gives some information about the meta variable that got compiled.+  deriving (Data, Show, Eq, Ord, Generic)   class Unreachable a where@@ -231,3 +248,42 @@  instance KillRange Compiled where   killRange c = c -- bogus, but not used anyway+++-- * Utilities for ArgUsage+---------------------------------------------------------------------------++-- | @filterUsed used args@ drops those @args@ which are labelled+-- @ArgUnused@ in list @used@.+--+-- Specification:+--+-- @+--   filterUsed used args = [ a | (a, ArgUsed) <- zip args $ used ++ repeat ArgUsed ]+-- @+--+-- Examples:+--+-- @+--   filterUsed []                 == id+--   filterUsed (repeat ArgUsed)   == id+--   filterUsed (repeat ArgUnused) == const []+-- @+filterUsed :: [ArgUsage] -> [a] -> [a]+filterUsed = curry $ \case+  ([], args) -> args+  (_ , [])   -> []+  (ArgUsed   : used, a : args) -> a : filterUsed used args+  (ArgUnused : used, a : args) ->     filterUsed used args++-- NFData instances+---------------------------------------------------------------------------++instance NFData Compiled+instance NFData ArgUsage+instance NFData TTerm+instance NFData TPrim+instance NFData CaseType+instance NFData CaseInfo+instance NFData TAlt+instance NFData TError

src/full/Agda/Termination/CallGraph.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE ImplicitParams             #-} @@ -102,8 +101,8 @@ -- | Converts a list of calls with associated meta information to a --   call graph. -fromList :: [Call cinfo] -> CallGraph cinfo-fromList = CallGraph . Graph.fromEdgesWith CMSet.union+fromListCG :: [Call cinfo] -> CallGraph cinfo+fromListCG = CallGraph . Graph.fromEdgesWith CMSet.union  -- | 'null' checks whether the call graph is completely disconnected. instance Null (CallGraph cinfo) where@@ -124,6 +123,12 @@ instance Monoid (CallGraph cinfo) where   mempty  = empty   mappend = (<>)++instance Singleton (Call cinfo) (CallGraph cinfo) where+  singleton = fromList . singleton++instance Collection (Call cinfo) (CallGraph cinfo) where+  fromList = fromListCG  -- | Inserts a call into a call graph.

src/full/Agda/Termination/CallMatrix.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams             #-} {-# LANGUAGE CPP                        #-} @@ -14,8 +13,6 @@ #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)  import Agda.Termination.CutOff import Agda.Termination.Order as Order

src/full/Agda/Termination/CutOff.hs view

@@ -4,12 +4,17 @@ --   "Agda.TypeChecking.Monad.Base" on the termination checker and --   everything it imports. -module Agda.Termination.CutOff where+module Agda.Termination.CutOff+  ( CutOff(CutOff, DontCutOff)+  , defaultCutOff+  ) where +import Control.DeepSeq+ -- | 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@.+  = CutOff !Int -- ^ @c >= 0@ means: record decrease up to including @c+1@.   | DontCutOff   deriving (Eq , Ord) @@ -17,4 +22,11 @@   show (CutOff k) = show k   show DontCutOff = "∞" --- That's it!+instance NFData CutOff where+  rnf (CutOff _) = ()+  rnf DontCutOff = ()++-- | The default termination depth.++defaultCutOff :: CutOff+defaultCutOff = CutOff 0 -- minimum value

src/full/Agda/Termination/Monad.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | The monad for the termination checker. --@@ -14,17 +13,14 @@  import qualified Control.Monad.Fail as Fail +import Control.Monad.Except import Control.Monad.Reader -import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Data.Monoid ( Monoid(..) ) import Data.Semigroup ( Semigroup(..) ) import qualified Data.Set as Set -import Agda.Interaction.Options+import Agda.Interaction.Options (optTerminationDepth) -import Agda.Syntax.Abstract (AllNames) import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern@@ -37,13 +33,12 @@  import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Benchmark-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import Agda.Utils.Except ( MonadError )+import Agda.Utils.Benchmark as B import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens@@ -185,7 +180,6 @@            , Monad            , Fail.MonadFail            , MonadError TCErr-           , MonadBench Phase            , MonadStatistics            , HasOptions            , HasBuiltins@@ -198,8 +192,19 @@            , ReadTCState            , MonadReduce            , MonadAddContext+           , PureTCM            ) +-- This could be derived automatically, but the derived type family becomes `BenchPhase (ReaderT TerEnv TCM)` which+-- is *fine* but triggers complaints that the "type family application is no smaller than the instance head, why not+-- nuke everything with UndecidableInstances".+instance MonadBench TerM where+  type BenchPhase TerM = Phase+  getBenchmark              = TerM $ B.getBenchmark+  putBenchmark              = TerM . B.putBenchmark+  modifyBenchmark           = TerM . B.modifyBenchmark+  finally (TerM m) (TerM f) = TerM $ (B.finally m f)+ instance MonadTer TerM where   terAsk     = TerM $ ask   terLocal f = TerM . local f . terM@@ -453,7 +458,7 @@                   , addContext tel $ prettyTCM core                   ]                 when (null mut) __IMPOSSIBLE__-                names <- anyDefs (mut `hasElem`) =<< normalise (map (snd . unDom) tel', core)+                names <- anyDefs (mut `hasElem`) (map (snd . unDom) tel', core)                 reportSDoc "term.guardedness" 40 $                   "found" <+> if null names then "none" else sep (map prettyTCM $ Set.toList names)                 return $ not $ null names@@ -493,7 +498,7 @@ --   for structural descent.  unusedVar :: DeBruijnPattern-unusedVar = litP (LitString noRange "term.unused.pat.var")+unusedVar = litP (LitString "term.unused.pat.var")  -- | Extract variables from 'DeBruijnPattern's that could witness a decrease --   via a SIZELT constraint.@@ -579,7 +584,7 @@ --   Performance-wise, I could not see a difference between Set and list.  newtype CallPath = CallPath { callInfos :: [CallInfo] }-  deriving (Show, Semigroup, Monoid, AllNames)+  deriving (Show, Semigroup, Monoid)  -- | Only show intermediate nodes.  (Drop last 'CallInfo'). instance Pretty CallPath where

src/full/Agda/Termination/Order.hs view

@@ -138,7 +138,7 @@  -- | Raw increase which does not cut off. increase :: Int -> Order -> Order-increase i o = case o of+increase i = \case   Unknown  -> Unknown   Decr u k -> Decr u $ k - i   -- TODO: should we set u to False if k - i < 0 ?   Mat m    -> Mat $ fmap (increase i) m@@ -207,7 +207,7 @@  instance Pretty Order where   pretty (Decr u 0) = "="-  pretty (Decr u k) = mparens (not u) $ text $ show (0 - k)+  pretty (Decr u k) = mparens (not u) $ text $ show (negate k)   pretty Unknown    = "?"   pretty (Mat m)    = "Mat" <+> pretty m @@ -253,7 +253,7 @@  -- | Can two matrices be multplied together? okM :: Matrix Int Order -> Matrix Int Order -> Bool-okM m1 m2 = (rows $ size m2) == (cols $ size m1)+okM m1 m2 = rows (size m2) == cols (size m1)  -- | The supremum of a (possibly empty) list of 'Order's. --   More information (i.e., more decrease) is bigger.

src/full/Agda/Termination/RecCheck.hs view

@@ -11,7 +11,6 @@    This implementation by Andreas. -} -{-# LANGUAGE CPP #-}  module Agda.Termination.RecCheck     ( recursive@@ -23,7 +22,6 @@ import Data.Graph import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Set (Set)@@ -34,7 +32,6 @@  import Agda.TypeChecking.Monad -import Agda.Utils.Functor ((<.>)) import Agda.Utils.List    (hasElem) import Agda.Utils.Pretty  (prettyShow) @@ -124,8 +121,8 @@    reportS "rec.graph" 20     [ "recDef " ++ prettyShow name-    , "  names in the type: " ++ show ns1-    , "  names in the def:  " ++ show ns2+    , "  names in the type: " ++ prettyShow ns1+    , "  names in the def:  " ++ prettyShow ns2     ]   return (perClause, ns1 `mappend` ns2)

src/full/Agda/Termination/SparseMatrix.hs view

@@ -53,9 +53,7 @@ import Data.Maybe  -import Data.Foldable (Foldable) import qualified Data.Foldable as Fold-import Data.Traversable (Traversable)  import qualified Text.PrettyPrint.Boxes as Boxes

src/full/Agda/Termination/TermCheck.hs view

@@ -1,6 +1,5 @@-{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ {-# LANGUAGE ImplicitParams             #-} {-# LANGUAGE NondecreasingIndentation   #-} @@ -19,15 +18,14 @@  import Prelude hiding ( null ) +import Control.Applicative (liftA2) import Control.Monad.Reader  import Data.Foldable (toList) import qualified Data.List as List import Data.Monoid hiding ((<>)) import qualified Data.Set as Set-import Data.Traversable (Traversable, traverse) -import Agda.Syntax.Abstract (IsProjP(..), AllNames(..)) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern as I@@ -51,7 +49,6 @@ import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Functions import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records -- (isRecordConstructor, isInductiveRecord) import Agda.TypeChecking.Reduce (reduce, normalise, instantiate, instantiateFull, appDefE')@@ -68,12 +65,13 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.List-import Agda.Utils.Size import Agda.Utils.Maybe import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M) import Agda.Utils.Null import Agda.Utils.Pretty (prettyShow) 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.Impossible@@ -99,7 +97,7 @@ --   (without necessarily ignoring @abstract@).  termDecl' :: A.Declaration -> TCM Result-termDecl' d = case d of+termDecl' = \case     A.Axiom {}            -> return mempty     A.Field {}            -> return mempty     A.Primitive {}        -> return mempty@@ -117,7 +115,7 @@     A.ScopedDecl scope ds -> {- withScope_ scope $ -} termDecls ds         -- scope is irrelevant as we are termination checking Syntax.Internal     A.RecSig{}            -> return mempty-    A.RecDef _ r _ _ _ _ _ _ ds -> termDecls ds+    A.RecDef _ r _ _ _ _ ds -> termDecls ds     -- These should all be wrapped in mutual blocks     A.FunDef{}      -> __IMPOSSIBLE__     A.DataSig{}     -> __IMPOSSIBLE__@@ -127,16 +125,11 @@   where     termDecls ds = concat <$> mapM termDecl' ds -    unscopeDefs = concatMap unscopeDef--    unscopeDef (A.ScopedDecl _ ds) = unscopeDefs ds-    unscopeDef d = [d]-     -- The mutual names mentioned in the abstract syntax     -- for symbols that need to be termination-checked.     getNames = concatMap getName     getName (A.FunDef i x delayed cs)   = [x]-    getName (A.RecDef _ _ _ _ _ _ _ _ ds) = getNames ds+    getName (A.RecDef _ _ _ _ _ _ ds)   = getNames ds     getName (A.Mutual _ ds)             = getNames ds     getName (A.Section _ _ _ ds)        = getNames ds     getName (A.ScopedDecl _ ds)         = getNames ds@@ -251,7 +244,19 @@   cutoff <- terGetCutOff   let ?cutoff = cutoff   r <- billToTerGraph $ Term.terminates calls1-  r <- case r of+  r <-+       -- 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.+       ifM (optCubical <$> pragmaOptions) (return r) {- else -} $+       case r of          r@Right{} -> return r          Left{}    -> do            -- Try again, but include the dot patterns this time.@@ -273,7 +278,9 @@ --   Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'. terminationError :: [QName] -> [CallInfo] -> TerminationError terminationError names calls = TerminationError names' calls-  where names' = names `List.intersect` toList (allNames calls)+  where+  names'    = filter (hasElem mentioned) names+  mentioned = map callInfoTarget calls  billToTerGraph :: a -> TerM a billToTerGraph a = liftTCM $ billPureTo [Benchmark.Termination, Benchmark.Graph] a@@ -542,7 +549,7 @@  termToDBP :: Term -> TerM DeBruijnPattern termToDBP t = ifNotM terGetUseDotPatterns (return unusedVar) $ {- else -} do-  termToPattern =<< do liftTCM $ stripAllProjections =<< normalise t+  termToPattern =<< do liftTCM $ stripAllProjections t  -- | Convert a term (from a dot pattern) to a pattern for the purposes of the termination checker. --@@ -563,12 +570,12 @@ --   termToPattern t = unnamed <$> termToPattern t  instance TermToPattern Term DeBruijnPattern where-  termToPattern t = (liftTCM $ constructorForm t) >>= \case+  termToPattern t = liftTCM (reduce t >>= constructorForm) >>= \case     -- Constructors.     Con c _ args -> 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 Inductive []) noConPatternInfo . map (fmap unnamed) <$> termToPattern [arg]+      if Just s == suc then ConP (ConHead s IsData Inductive []) noConPatternInfo . map (fmap unnamed) <$> termToPattern [arg]        else return $ dotP t     DontCare t  -> termToPattern t -- OR: __IMPOSSIBLE__  -- removed by stripAllProjections     -- Leaves.@@ -597,7 +604,7 @@     , nest 2 $ "ps  =" <+> do addContext tel $ prettyTCMPatternList ps     ]   forM' body $ \ v -> addContext tel $ do-    -- TODO: combine the following two traversals, avoid full normalisation.+    -- TODO: combine the following two traversals.     -- Parse dot patterns as patterns as far as possible.     ps <- postTraversePatternM parseDotP ps     -- Blank out coconstructors.@@ -614,7 +621,7 @@       DotP o t -> termToDBP t       p        -> return p     stripCoCon p = case p of-      ConP (ConHead c _ _) _ _ -> do+      ConP (ConHead c _ _ _) _ _ -> do         ifM ((Just c ==) <$> terGetSizeSuc) (return p) $ {- else -} do         whatInduction c >>= \case           Inductive   -> return p@@ -660,6 +667,9 @@ instance (ExtractCalls a, ExtractCalls b) => ExtractCalls (a,b) where   extract (a, b) = CallGraph.union <$> extract a <*> extract b +instance (ExtractCalls a, ExtractCalls b, ExtractCalls c) => ExtractCalls (a,b,c) where+  extract (a, b, c) = extract (a, (b, c))+ -- | Sorts can contain arbitrary terms of type @Level@, --   so look for recursive calls also in sorts. --   Ideally, 'Sort' would not be its own datatype but just@@ -673,11 +683,13 @@       reportSDoc "term.sort" 50 $         text ("s = " ++ show s)     case s of-      Inf        -> return empty+      Inf f n    -> return empty       SizeUniv   -> return empty+      LockUniv   -> return empty       Type t     -> terUnguarded $ extract t  -- no guarded levels       Prop t     -> terUnguarded $ extract t-      PiSort a s -> extract (a, s)+      SSet t     -> terUnguarded $ extract t+      PiSort a s1 s2 -> extract (a, s1, s2)       FunSort s1 s2 -> extract (s1, s2)       UnivSort s -> extract s       MetaS x es -> return empty@@ -726,17 +738,6 @@      -- First, look for calls in the arguments of the call gArgs. -    -- 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.-    let (reduceCon :: Term -> TCM Term) = traverseTermM $ \ t -> case t of-           Con c ci vs -> (`applyE` vs) <$> reduce (Con c ci [])  -- make sure we don't reduce the arguments-           _ -> return t--    -- Reduce constructors only when this call is actually a recursive one.-    -- es <- liftTCM $ billTo [Benchmark.Termination, Benchmark.Reduce] $ forM es $-    --         etaContract <=< traverse reduceCon <=< instantiateFull-     -- If the function is a projection but not for a coinductive record,     -- then preserve guardedness for its principal argument.     isProj <- isProjectionButNotCoinductive g@@ -771,12 +772,11 @@          es <- -- ifM terGetHaveInlinedWith (return es0) {-else-} $            liftTCM $ forM es0 $              -- 2017-09-09, re issue #2732-             -- The eta-contraction here does not seem necessary to make structural order+             -- The eta-contraction that was here does not seem necessary to make structural order              -- comparison not having to worry about eta.              -- Maybe we thought an eta redex could come from a meta instantiation.              -- However, eta-contraction is already performed by instantiateFull.              -- See test/Succeed/Issue2732-termination.agda.-             -- etaContract <=<              traverse reduceCon <=< instantiateFull             -- 2017-05-16, issue #2403: Argument normalization is too expensive,@@ -822,7 +822,7 @@          -- otherwise its free variables with be prepended to the call          -- in the error message.          doc <- liftTCM $ withCurrentModule (qnameModule g) $ buildClosure $-           Def g $ reverse $ dropWhile ((Inserted ==) . getOrigin) $ reverse es0+           Def g $ List.dropWhileEnd ((Inserted ==) . getOrigin) es0            -- Andreas, 2018-07-22, issue #3136            -- Dropping only inserted arguments at the end, since            -- dropping arguments in the middle might make the printer crash.@@ -849,6 +849,16 @@              ]          return $ CallGraph.insert src tgt cm info calls +  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++ -- | Try to get rid of a function call targeting the current SCC --   using a non-recursive clause. --@@ -870,11 +880,14 @@    -- Then, collect its non-recursive clauses.   cls <- liftTCM $ getNonRecursiveClauses g-  reportSLn "term.reduce" 40 $ unwords [ "Function has", show (length cls), "non-recursive clauses"]+  reportSLn "term.reduce" 40 $ unwords [ "Function has", show (length cls), "non-recursive exact 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 $ runReduceM $ appDefE' v0 cls [] (map notReduced es)+  r <- liftTCM $ modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $+    runReduceM $ appDefE' v0 cls [] (map notReduced es)   case r of     NoReduction{}    -> fallback     YesReduction _ v -> do@@ -886,8 +899,11 @@       continue v  getNonRecursiveClauses :: QName -> TCM [Clause]-getNonRecursiveClauses q = filter nonrec . defClauses <$> getConstInfo q-  where nonrec = maybe False not . clauseRecursive+getNonRecursiveClauses q =+  filter (liftA2 (&&) nonrec exact) . defClauses <$> getConstInfo q+  where+  nonrec = maybe False not . clauseRecursive+  exact  = fromMaybe False . clauseExact  -- | Extract recursive calls from a term. @@ -901,7 +917,7 @@     case t of        -- Constructed value.-      Con ConHead{conName = c} _ es -> do+      Con ConHead{conName = c, conDataRecord = dataOrRec} _ es -> do         let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es         -- A constructor preserves the guardedness of all its arguments.         let argsg = zip args $ repeat True@@ -909,13 +925,16 @@         -- If we encounter a coinductive record constructor         -- in a type mutual with the current target         -- then we count it as guarding.-        ind <- ifM ((Just c ==) <$> terGetSharp) (return CoInductive) $ do-          caseMaybeM (liftTCM $ isRecordConstructor c) (return Inductive) $ \ (q, def) -> do+        let inductive   = return Inductive+            coinductive = return CoInductive+        ind <- ifM ((Just c ==) <$> terGetSharp) coinductive $ {-else-} do+          if dataOrRec == IsData then inductive else do+          caseMaybeM (liftTCM $ isRecordConstructor c) inductive $ \ (q, def) -> do             reportSLn "term.check.term" 50 $ "constructor " ++ prettyShow c ++ " has record type " ++ prettyShow q-            (\ b -> if b then CoInductive else Inductive) <$>-              andM [ return $ recInduction def == Just CoInductive-                   , targetElem . fromMaybe __IMPOSSIBLE__ $ recMutual def-                   ]+            if recInduction def /= Just CoInductive then inductive else do+            ifM (targetElem . fromMaybe __IMPOSSIBLE__ $ recMutual def)+               {-then-} coinductive+               {-else-} inductive         constructor c ind argsg        -- Function, data, or record type.@@ -968,12 +987,6 @@ instance ExtractCalls PlusLevel where   extract (Plus n l) = extract l -instance ExtractCalls LevelAtom where-  extract (MetaLevel x es)   = extract es-  extract (BlockedLevel x t) = extract t-  extract (NeutralLevel _ t) = extract t-  extract (UnreducedLevel t) = extract t- -- | Rewrite type @tel -> Size< u@ to @tel -> Size@. maskSizeLt :: MonadTCM tcm => Dom Type -> tcm (Dom Type) maskSizeLt !dom = liftTCM $ do@@ -986,7 +999,7 @@       TelV tel c <- telView a       case a of         El s (Def d [v]) | d == sizelt -> return $-          (abstract tel $ El s $ Def size []) <$ dom+          abstract tel (El s $ Def size []) <$ dom         _ -> return dom  {- | @compareArgs es@

src/full/Agda/TypeChecking/Abstract.hs view

@@ -1,27 +1,29 @@-{-# LANGUAGE UndecidableInstances #-}  -- | Functions for abstracting terms over other terms. module Agda.TypeChecking.Abstract where  import Control.Monad+import Control.Monad.Except+ import Data.Function import qualified Data.HashMap.Strict as HMap  import Agda.Syntax.Common import Agda.Syntax.Internal +import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (equalityUnview)+import Agda.TypeChecking.Monad.Builtin ( equalityUnview, primEqualityName ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.CheckInternal import Agda.TypeChecking.Conversion import Agda.TypeChecking.Constraints import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Sort+import Agda.TypeChecking.Telescope  import Agda.Utils.Functor-import Agda.Utils.List (splitExactlyAt)-import Agda.Utils.Except-+import Agda.Utils.List ( splitExactlyAt, dropEnd ) import Agda.Utils.Impossible  -- | @abstractType a v b[v] = b@ where @a : v@.@@ -30,9 +32,9 @@  -- | @piAbstractTerm NotHidden v a b[v] = (w : a) -> b[w]@ --   @piAbstractTerm Hidden    v a b[v] = {w : a} -> b[w]@-piAbstractTerm :: Hiding -> Term -> Type -> Type -> TCM Type-piAbstractTerm h v a b = do-  fun <- mkPi (setHiding h $ defaultDom ("w", a)) <$> abstractType a v b+piAbstractTerm :: ArgInfo -> Term -> Type -> Type -> TCM Type+piAbstractTerm info v a b = do+  fun <- mkPi (setArgInfo info $ defaultDom ("w", a)) <$> abstractType a v b   reportSDoc "tc.abstract" 50 $     sep [ "piAbstract" <+> sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ]         , nest 2 $ "from" <+> prettyTCM b@@ -45,14 +47,42 @@  -- | @piAbstract (v, a) b[v] = (w : a) -> b[w]@ -----   For @rewrite@, it does something special:+--   For the inspect idiom, it does something special:+--   @piAbstract (v, a) b[v] = (w : a) {w' : Eq a w v} -> b[w] --+--   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 :: WithHiding (Term, EqualityView) -> Type -> TCM Type-piAbstract (WithHiding h (v, OtherType a))                              b = piAbstractTerm h v a b-piAbstract (WithHiding h (prf, eqt@(EqualityType _ _ _ (Arg _ a) v _))) b = do-  s <- inferSort a+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 a v b+  eq <- addContext ("w" :: String, defaultDom a) $ do+    -- manufacture the type @w ≡ v@+    eqName <- primEqualityName+    eqTy <- defType <$> getConstInfo eqName+    -- E.g. @eqTy = eqTel → Set a@ where @eqTel = {a : Level} {A : Set a} (x y : A)@.+    TelV eqTel _ <- telView eqTy+    tel  <- newTelMeta (telFromList $ dropEnd 2 $ telToList eqTel)+    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`.+                 ++ [ defaultArg (raise 1 v)+                    , defaultArg (var 0)+                    ]+    sort <- newSortMeta+    let ty = El sort eq+    ty <$ checkType ty++  pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a))+       $ mkPi (setHiding NotHidden        $ defaultDom ("eq", eq))+       $ b+piAbstract (Arg info (prf, eqt@(EqualityType _ _ _ (Arg _ a) v _))) b = do+  s <- sortOf a   let prfTy = equalityUnview eqt       vTy   = El s a   b <- abstractType prfTy prf b@@ -60,11 +90,12 @@          abstractType (raise 1 vTy) (unArg $ raise 1 v) b   return . funType "lhs" vTy . funType "equality" eqTy' . swap01 $ b   where-    funType str a = mkPi $ setHiding h $ defaultDom (str, a)+    funType str a = mkPi $ setArgInfo info $ defaultDom (str, a)     -- Abstract the lhs (@a@) of the equality only.     eqt1  = raise 1 eqt     eqTy' = equalityUnview $ eqt1 { eqtLhs = eqtLhs eqt1 $> var 0 } + -- | @isPrefixOf u v = Just es@ if @v == u `applyE` es@. class IsPrefixOf a where   isPrefixOf :: a -> a -> Maybe Elims@@ -105,7 +136,7 @@         , nest 2 $ sep [ (text . show) v <+> ":", nest 2 $ (text . show) b ] ]    hole <- qualify <$> currentModule <*> freshName_ ("hole" :: String)-  noMutualBlock $ addConstant hole $ defaultDefn defaultArgInfo hole a Axiom+  noMutualBlock $ addConstant hole $ defaultDefn defaultArgInfo hole a defaultAxiom    args <- map Apply <$> getContextArgs   let n = length args@@ -113,7 +144,7 @@   let abstr b v = do         m <- getContextSize         let (a', u') = raise (m - n) (a, u)-        case isPrefixOf u' v of+        case u' `isPrefixOf` v of           Nothing -> return v           Just es -> do -- Check that the types match.             s <- getTC@@ -163,24 +194,29 @@       DontCare mv -> DontCare $ absT mv       Dummy s es   -> Dummy s $ absT es       where+        absT :: AbsTerm b => b -> b         absT x = absTerm u x  instance AbsTerm Type where   absTerm u (El s v) = El (absTerm u s) (absTerm u v)  instance AbsTerm Sort where-  absTerm u s = case s of+  absTerm u = \case     Type n     -> Type $ absS n     Prop n     -> Prop $ absS n-    Inf        -> Inf+    s@(Inf f n)-> s+    SSet n     -> SSet $ absS n     SizeUniv   -> SizeUniv-    PiSort a s -> PiSort (absS a) (absS s)+    LockUniv   -> LockUniv+    PiSort a s1 s2 -> PiSort (absS a) (absS s1) (absS s2)     FunSort s1 s2 -> FunSort (absS s1) (absS s2)     UnivSort s -> UnivSort $ absS s     MetaS x es -> MetaS x $ absS es     DefS d es  -> DefS d $ absS es-    DummyS{}   -> s-    where absS x = absTerm u x+    s@DummyS{} -> s+    where+      absS :: AbsTerm b => b -> b+      absS x = absTerm u x  instance AbsTerm Level where   absTerm u (Max n as) = Max n $ absTerm u as@@ -188,13 +224,6 @@ instance AbsTerm PlusLevel where   absTerm u (Plus n l) = Plus n $ absTerm u l -instance AbsTerm LevelAtom where-  absTerm u l = case l of-    MetaLevel m vs   -> UnreducedLevel $ absTerm u (MetaV m vs)-    NeutralLevel r v -> NeutralLevel r $ absTerm u v-    BlockedLevel _ v -> UnreducedLevel $ absTerm u v -- abstracting might remove the blockage-    UnreducedLevel v -> UnreducedLevel $ absTerm u v- instance AbsTerm a => AbsTerm (Elim' a) where   absTerm = fmap . absTerm @@ -210,7 +239,7 @@ instance AbsTerm a => AbsTerm (Maybe a) where   absTerm = fmap . absTerm -instance (Subst Term a, AbsTerm a) => AbsTerm (Abs a) where+instance (TermSubst a, AbsTerm a) => AbsTerm (Abs a) where   absTerm u (NoAbs x v) = NoAbs x $ absTerm u v   absTerm u (Abs   x v) = Abs x $ swap01 $ absTerm (raise 1 u) v @@ -218,7 +247,7 @@   absTerm u (x, y) = (absTerm u x, absTerm u y)  -- | This swaps @var 0@ and @var 1@.-swap01 :: (Subst Term a) => a -> a+swap01 :: TermSubst a => a -> a swap01 = applySubst $ var 1 :# liftS 1 (raiseS 1)  @@ -257,16 +286,14 @@ instance EqualSy PlusLevel where   equalSy (Plus n v) (Plus n' v') = n == n' && equalSy v v' -instance EqualSy LevelAtom where-  equalSy = equalSy `on` unLevelAtom- instance EqualSy Sort where   equalSy = curry $ \case     (Type l    , Type l'     ) -> equalSy l l'     (Prop l    , Prop l'     ) -> equalSy l l'-    (Inf       , Inf         ) -> True+    (Inf f m   , Inf f' n    ) -> f == f' && m == n+    (SSet l    , SSet l'     ) -> equalSy l l'     (SizeUniv  , SizeUniv    ) -> True-    (PiSort a b, PiSort a' b') -> equalSy a a' && equalSy b b'+    (PiSort a b c, PiSort a' b' c') -> equalSy a a' && equalSy b b' && equalSy c c'     (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'@@ -282,24 +309,23 @@ instance EqualSy a => EqualSy (Elim' a) where   equalSy = curry $ \case     (Proj _ f, Proj _ f') -> f == f'-    (Apply a , Apply a' ) -> equalSy a a'-    (IApply u v r, IApply u' v' r') -> and-      [ equalSy u u'-      , equalSy v v'-      , equalSy r r'-      ]+    (Apply a, Apply a') -> equalSy a a'+    (IApply u v r, IApply u' v' r') ->+           equalSy u u'+        && equalSy v v'+        && equalSy r r'     _ -> False  -- | Ignores 'absName'.-instance (Subst t a, EqualSy a) => EqualSy (Abs a) where+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     (a         , a'          ) -> equalSy (absBody a) (absBody a')  -- | Ignore origin and free variables. instance EqualSy ArgInfo where-  equalSy (ArgInfo h m _o _fv) (ArgInfo h' m' _o' _fv') =-    h == h' && m == m'+  equalSy (ArgInfo h m _o _fv a) (ArgInfo h' m' _o' _fv' a') =+    h == h' && m == m' && a == a'  -- | Ignore the tactic. instance EqualSy a => EqualSy (Dom a) where@@ -313,7 +339,7 @@ -- | Ignores irrelevant arguments and modality. --   (And, of course, origin and free variables). instance EqualSy a => EqualSy (Arg a) where-  equalSy (Arg (ArgInfo h m _o _fv) v) (Arg (ArgInfo h' m' _o' _fv') v') =+  equalSy (Arg (ArgInfo h m _o _fv a) v) (Arg (ArgInfo h' m' _o' _fv' a') v') =     h == h' && (isIrrelevant m || isIrrelevant m' || equalSy v v')     -- Andreas, 2017-10-04, issue #2775,     -- ignore irrelevant arguments during with-abstraction.

src/full/Agda/TypeChecking/CheckInternal.hs view

@@ -14,9 +14,10 @@   , checkSort   , checkInternal   , checkInternal'+  , checkInternalType'   , Action(..), defaultAction, eraseUnusedAction   , infer-  , inferSort+  , inferSpine'   , shouldBeSort   ) where @@ -30,9 +31,8 @@ import Agda.TypeChecking.Datatypes -- (getConType, getFullyAppliedConType) import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty-import Agda.TypeChecking.ProjectionLike (elimView)+import Agda.TypeChecking.ProjectionLike (elimView, ProjEliminator(..)) import Agda.TypeChecking.Records (getDefType) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute@@ -56,7 +56,9 @@  -- | Entry point for e.g. checking WithFunctionType. checkType :: (MonadCheckInternal m) => Type -> m ()-checkType t = void $ checkType' t+checkType t = do+  inferred <- checkType' t+  equalSort (getSort t) inferred  -- | Check a type and infer its sort. --@@ -73,7 +75,7 @@     [ "checking internal type "     , prettyTCM t     ]-  v <- elimView True $ unEl t -- bring projection-like funs in post-fix form+  v <- elimView EvenLone $ unEl t -- bring projection-like funs in post-fix form   case v of     Pi a b -> do       s1 <- checkType' $ unDom a@@ -104,6 +106,10 @@ checkTypeSpine :: (MonadCheckInternal m) => Type -> Term -> Elims -> m Sort checkTypeSpine a self es = shouldBeSort =<< do snd <$> inferSpine a self es +checkInternalType' :: (MonadCheckInternal m) => Action m -> Type -> m Type+checkInternalType' act El{_getSort=s, unEl=t} = do+  tAfterAct <- checkInternal' act t CmpLeq (sort s)+  return El{_getSort=s, unEl=tAfterAct}  -- | 'checkInternal' traverses the whole 'Term', and we can use this --   traversal to modify the term.@@ -112,29 +118,33 @@     -- ^ Called on each subterm before the checker runs.   , postAction :: Type -> Term -> m Term     -- ^ Called on each subterm after the type checking.-  , relevanceAction :: Relevance -> Relevance -> Relevance+  , modalityAction :: Modality -> Modality -> Modality     -- ^ Called for each @ArgInfo@.-    --   The first 'Relevance' is from the type,+    --   The first 'Modality' is from the type,     --   the second from the term.+  , elimViewAction :: Term -> m Term+    -- ^ Called for bringing projection-like funs in post-fix form   }  -- | The default action is to not change the 'Term' at all.-defaultAction :: Monad m => Action m+defaultAction :: PureTCM m => Action m+--(MonadReduce m, MonadTCEnv m, HasConstInfo m) => Action m defaultAction = Action   { preAction       = \ _ -> return   , postAction      = \ _ -> return-  , relevanceAction = \ _ -> id+  , modalityAction  = \ _ -> id+  , elimViewAction  = elimView EvenLone   }  eraseUnusedAction :: Action TCM eraseUnusedAction = defaultAction { postAction = eraseUnused }   where     eraseUnused :: Type -> Term -> TCM Term-    eraseUnused t v = case v of+    eraseUnused t = \case       Def f es -> do         pols <- getPolarity f         return $ Def f $ eraseIfNonvariant pols es-      _        -> return v+      v        -> return v      eraseIfNonvariant :: [Polarity] -> Elims -> Elims     eraseIfNonvariant []                  es             = es@@ -152,9 +162,17 @@     [ "checking internal "     , nest 2 $ sep [ prettyTCM v <+> ":"                    , nest 2 $ prettyTCM t ] ]+  reportSDoc "tc.check.internal" 30 $ sep+    [ "checking internal with DB indices"+    , nest 2 $ sep [ pretty v <+> ":"+                   , nest 2 $ pretty t ] ]+  ctx <- getContextTelescope+  reportSDoc "tc.check.internal" 30 $ sep+    [ "In context"+    , nest 2 $ sep [ prettyTCM ctx ] ]   -- Bring projection-like funs in post-fix form,-  -- even lone ones (True).-  v <- elimView True =<< preAction action t v+  -- (even lone ones by default).+  v <- elimViewAction action =<< preAction action t v   postAction action t =<< case v of     Var i es   -> do       a <- typeOfBV i@@ -173,11 +191,11 @@       fullyApplyCon c vs t $ \ _d _dt _pars a vs' tel t -> do         Con c ci vs2 <- checkSpine action a (Con c ci []) vs' cmp t         -- Strip away the extra arguments-        return $ applySubst (strengthenS __IMPOSSIBLE__ (size tel))+        return $ applySubst (strengthenS impossible (size tel))           $ Con c ci $ take (length vs) vs2     Lit l      -> do       lt <- litType l-      cmptype cmp lt t+      compareType cmp lt t       return $ Lit l     Lam ai vb  -> do       (a, b) <- maybe (shouldBePi t) return =<< isPath t@@ -210,7 +228,7 @@     Level l    -> do       l <- checkLevel action l       lt <- levelType-      cmptype cmp lt t+      compareType cmp lt t       return $ Level l     DontCare v -> DontCare <$> checkInternal' action v cmp t     Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s@@ -237,7 +255,8 @@   -- The type of the constructor application may still be a function   -- type.  In this case, we introduce the domains @tel@ into the context   -- and apply the constructor to these fresh variables.-  addContext tel $ ifBlocked t (\m t -> patternViolation) $ \_ t -> do+  addContext tel $ do+    t <- abortIfBlocked t     getFullyAppliedConType c t >>= \case       Nothing ->         typeError $ DoesNotConstructAnElementOf (conName c) t@@ -262,7 +281,7 @@                    , nest 2 $ prettyTCM t ] ]   ((v, v'), t') <- inferSpine' action a self self es   t' <- reduce t'-  v' <$ coerceSize (cmptype cmp) v t' t+  v' <$ coerceSize (compareType cmp) v t' t --UNUSED Liang-Ting Chen 2019-07-16 --checkArgs --  :: (MonadCheckInternal m)@@ -282,8 +301,8 @@ checkArgInfo :: (MonadCheckInternal m) => Action m -> ArgInfo -> ArgInfo -> m ArgInfo checkArgInfo action ai ai' = do   checkHiding    (getHiding ai)     (getHiding ai')-  r <- checkRelevance action (getRelevance ai)  (getRelevance ai')-  return $ setRelevance r ai+  mod <- checkModality action (getModality ai)  (getModality ai')+  return $ setModality mod ai  checkHiding    :: (MonadCheckInternal m) => Hiding -> Hiding -> m () checkHiding    h h' = unless (sameHiding h h') $ typeError $ HidingMismatch h h'@@ -291,10 +310,15 @@ -- | @checkRelevance action term type@. -- --   The @term@ 'Relevance' can be updated by the @action@.-checkRelevance :: (MonadCheckInternal m) => Action m -> Relevance -> Relevance -> m Relevance-checkRelevance action r r' = do-  unless (r == r') $ typeError $ RelevanceMismatch r r'-  return $ relevanceAction action r' r  -- Argument order for actions: @type@ @term@+checkModality :: (MonadCheckInternal m) => Action m -> Modality -> Modality -> m Modality+checkModality action mod mod' = do+  let (r,r') = (getRelevance mod, getRelevance mod')+      (q,q') = (getQuantity  mod, getQuantity  mod')+  unless (sameModality mod mod') $ typeError $ if+    | not (sameRelevance r r') -> RelevanceMismatch r r'+    | not (sameQuantity q q')  -> QuantityMismatch  q q'+    | otherwise -> __IMPOSSIBLE__ -- add more cases when adding new modalities+  return $ modalityAction action mod' mod  -- Argument order for actions: @type@ @term@  -- | Infer type of a neutral term. infer :: (MonadCheckInternal m) => Term -> m Type@@ -343,10 +367,10 @@ inferSpine' action t self self' (e : es) = do   reportSDoc "tc.infer.internal" 30 $ sep     [ "inferSpine': "-    , "type t = " <+> prettyTCM t-    , "self  = " <+> prettyTCM self-    , "self' = " <+> prettyTCM self'-    , "eliminated by e = " <+> prettyTCM e+    , "type t = " <+> pretty t+    , "self  = " <+> pretty self+    , "self' = " <+> pretty self'+    , "eliminated by e = " <+> text (show e)     ]   case e of     IApply x y r -> do@@ -373,27 +397,24 @@ --   the principal argument of projection-like functions. shouldBeProjectible :: (MonadCheckInternal m) => Type -> QName -> m Type -- shouldBeProjectible t f = maybe failure return =<< projectionType t f-shouldBeProjectible t f = ifBlocked t-  (\m t -> patternViolation)-  (\_ t -> maybe failure return =<< getDefType f t)+shouldBeProjectible t f = do+    t <- abortIfBlocked t+    maybe failure return =<< getDefType f t   where failure = typeError $ ShouldBeRecordType t     -- TODO: more accurate error that makes sense also for proj.-like funs.  shouldBePath :: (MonadCheckInternal m) => Type -> m (Dom Type, Abs Type)-shouldBePath t = ifBlocked t-  (\m t -> patternViolation)-  (\_ t -> do-      m <- isPath t-      case m of-        Just p  -> return p-        Nothing -> typeError $ ShouldBePath t)+shouldBePath t = do+  t <- abortIfBlocked t+  m <- isPath t+  case m of+    Just p  -> return p+    Nothing -> typeError $ ShouldBePath t  shouldBePi :: (MonadCheckInternal m) => Type -> m (Dom Type, Abs Type)-shouldBePi t = ifBlocked t-  (\m t -> patternViolation)-  (\_ t -> case unEl t of-      Pi a b -> return (a , b)-      _      -> typeError $ ShouldBePi t)+shouldBePi t = abortIfBlocked t >>= \ case+  El _ (Pi a b) -> return (a, b)+  _             -> typeError $ ShouldBePi t  -- | Check if sort is well-formed. checkSort :: (MonadCheckInternal m) => Action m -> Sort -> m Sort@@ -401,15 +422,17 @@   case s of     Type l   -> Type <$> checkLevel action l     Prop l   -> Prop <$> checkLevel action l-    Inf      -> return Inf+    Inf f n  -> return $ Inf f n+    SSet l   -> SSet <$> checkLevel action l     SizeUniv -> return SizeUniv-    PiSort dom s2 -> do-      let El s1 a = unDom dom+    LockUniv -> return LockUniv+    PiSort dom s1 s2 -> do+      let a = unDom dom       s1' <- checkSort action s1       a' <- checkInternal' action a CmpLeq $ sort s1'-      let dom' = dom $> El s1' a'-      s2' <- mapAbstraction dom' (checkSort action) s2-      return $ PiSort dom' s2'+      let dom' = dom $> a'+      s2' <- mapAbstraction (El s1' <$> dom') (checkSort action) s2+      return $ PiSort dom' s1' s2'     FunSort s1 s2 -> do       s1' <- checkSort action s1       s2' <- checkSort action s2@@ -443,57 +466,11 @@      checkLevelAtom l = do       lvl <- levelType-      UnreducedLevel <$> case l of-        MetaLevel x es   -> checkInternal' action (MetaV x es) CmpLeq lvl-        BlockedLevel _ v -> checkInternal' action v CmpLeq lvl-        NeutralLevel _ v -> checkInternal' action v CmpLeq lvl-        UnreducedLevel v -> checkInternal' action v CmpLeq lvl+      checkInternal' action l CmpLeq lvl  -- | Universe subsumption and type equality (subtyping for sizes, resp.). cmptype :: (MonadCheckInternal m) => Comparison -> Type -> Type -> m () cmptype cmp t1 t2 = do-  ifIsSort t1 (\ s1 -> (compareSort cmp s1) =<< shouldBeSort t2) $ do     -- Andreas, 2017-03-09, issue #2493     -- Only check subtyping, do not solve any metas!     dontAssignMetas $ compareType cmp t1 t2---- | Compute the sort of a type.--inferSort :: (MonadCheckInternal m) => Term -> m Sort-inferSort t = case t of-    Var i es   -> do-      a <- typeOfBV i-      (_, s) <- eliminate (Var i []) a es-      shouldBeSort s-    Def f es   -> do  -- f is not projection(-like)!-      a <- defType <$> getConstInfo f-      (_, s) <- eliminate (Def f []) a es-      shouldBeSort s-    MetaV x es -> do-      a <- metaType x-      (_, s) <- eliminate (MetaV x []) a es-      shouldBeSort s-    Pi a b     -> inferPiSort a (getSort <$> b)-    Sort s     -> inferUnivSort s-    Con{}      -> __IMPOSSIBLE__-    Lit{}      -> __IMPOSSIBLE__-    Lam{}      -> __IMPOSSIBLE__-    Level{}    -> __IMPOSSIBLE__-    DontCare{} -> __IMPOSSIBLE__-    Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s---- | @eliminate t self es@ eliminates value @self@ of type @t@ by spine @es@---   and returns the remaining value and its type.-eliminate :: (MonadCheckInternal m) => Term -> Type -> Elims -> m (Term, Type)-eliminate self t [] = return (self, t)-eliminate self t (e : es) = case e of-    Apply (Arg _ v) -> ifNotPiType t __IMPOSSIBLE__ {-else-} $ \ _ b ->-      eliminate (self `applyE` [e]) (b `absApp` v) es-    IApply _ _ v -> do-      (_, b) <- shouldBePath t-      eliminate (self `applyE` [e]) (b `absApp` v) es-    -- case: projection or projection-like-    Proj o f -> do-      (Dom{domInfo = ai}, b) <- shouldBePi =<< shouldBeProjectible t f-      u  <- applyDef o f $ Arg ai self-      eliminate u (b `absApp` self) es

src/full/Agda/TypeChecking/CheckInternal.hs-boot view

@@ -2,37 +2,30 @@  module Agda.TypeChecking.CheckInternal where +import Control.Monad.Except import qualified Control.Monad.Fail as Fail  import qualified Data.Kind as Hs  import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (HasBuiltins)-import Agda.TypeChecking.Monad.Statistics (MonadStatistics) import Agda.TypeChecking.Warnings-import Agda.Utils.Except ( MonadError )  type MonadCheckInternal m =-  ( MonadReduce m-  , MonadAddContext m+  ( PureTCM m   , MonadConstraint m   , MonadMetaSolver m   , MonadError TCErr m   , MonadWarning m-  , MonadDebug m   , MonadStatistics m   , MonadFresh ProblemId m   , MonadFresh Int m-  , HasBuiltins m-  , HasConstInfo m-  , HasOptions m   , Fail.MonadFail m   )  data Action (m :: Hs.Type -> Hs.Type) -defaultAction :: Monad m => Action m+defaultAction :: PureTCM m => Action m eraseUnusedAction :: Action TCM  checkType :: (MonadCheckInternal m) => Type -> m ()

src/full/Agda/TypeChecking/CompiledClause.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}- -- | Case trees. -- --   After coverage checking, pattern matching is translated@@ -10,6 +8,8 @@  import Prelude hiding (null) +import Control.DeepSeq+ import qualified Data.Map as Map import Data.Map (Map) import Data.Semigroup hiding (Arg(..))@@ -19,6 +19,8 @@  import Data.Data (Data) +import GHC.Generics (Generic)+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic@@ -31,7 +33,7 @@ import Agda.Utils.Impossible  data WithArity c = WithArity { arity :: Int, content :: c }-  deriving (Data, Functor, Foldable, Traversable, Show)+  deriving (Data, Functor, Foldable, Traversable, Show, Generic)  -- | Branches in a case tree. @@ -55,7 +57,7 @@     -- ^ Lazy pattern match. Requires single (non-copattern) branch with no lit     --   branches and no catch-all.   }-  deriving (Data, Functor, Foldable, Traversable, Show)+  deriving (Data, Functor, Foldable, Traversable, Show, Generic)  -- | Case tree with bodies. @@ -70,9 +72,10 @@     --   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-    -- ^ Absurd case.-  deriving (Data, Functor, Traversable, Foldable, Show)+  | Fail [Arg ArgName]+    -- ^ Absurd case. Add the free variables here as well so we can build correct+    --   number of lambdas for strict backends. (#4280)+  deriving (Data, Functor, Traversable, Foldable, Show, Generic)  type CompiledClauses = CompiledClauses' Term @@ -162,7 +165,7 @@  instance Pretty a => Pretty (Case a) where   prettyPrec p (Branches _cop cs eta ls m b lazy) =-    mparens (p > 0) $ prLazy lazy <+> vcat (prettyMap cs ++ prEta eta ++ prettyMap ls ++ prC m)+    mparens (p > 0) $ prLazy lazy <+> vcat (prettyMap_ cs ++ prEta eta ++ prettyMap_ ls ++ prC m)     where       prLazy True  = "~"       prLazy False = empty@@ -171,14 +174,12 @@       prEta Nothing = []       prEta (Just (c, cc)) = [("eta" <+> pretty c <+> "->") <?> pretty cc] -prettyMap :: (Pretty k, Pretty v) => Map k v -> [Doc]-prettyMap m = [ sep [ pretty k <+> "->"-                    , nest 2 $ pretty v ]-              | (k, v) <- Map.toList m ]+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"+  pretty Fail{}      = "fail"   pretty (Case n bs) | projPatterns bs =     sep [ "record"         , nest 2 $ pretty bs@@ -202,7 +203,7 @@ instance KillRange CompiledClauses where   killRange (Case i br) = killRange2 Case i br   killRange (Done xs v) = killRange2 Done xs v-  killRange Fail        = Fail+  killRange (Fail xs)   = killRange1 Fail xs  -- * TermLike instances @@ -217,3 +218,9 @@ instance TermLike a => TermLike (CompiledClauses' 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)

src/full/Agda/TypeChecking/CompiledClause/Compile.hs view

@@ -9,8 +9,6 @@  import Data.Maybe import qualified Data.Map as Map-import Data.List (nubBy)-import Data.Function  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -18,7 +16,6 @@ import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Coverage import Agda.TypeChecking.Coverage.SplitTree-import Agda.TypeChecking.Forcing import Agda.TypeChecking.Monad import Agda.TypeChecking.RecordPatterns import Agda.TypeChecking.Substitute@@ -155,14 +152,14 @@     compiles _ _ Branches{etaBranch = Just{}} = __IMPOSSIBLE__  -- we haven't inserted eta matches yet  compile :: Cls -> CompiledClauses-compile [] = Fail+compile [] = Fail [] compile cs = case nextSplit cs of-  Just (isRecP, n) -> Case n $ fmap compile $ splitOn isRecP (unArg n) cs+  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+    Nothing -> Fail (map (fmap name) $ clPats c)   where     -- If there are more than one clauses, take the first one.     c = headWithDefault __IMPOSSIBLE__ cs@@ -399,7 +396,7 @@   ps'  = for ais $ \ ai -> Arg ai $ varP "_"   args = zipWith (\ i ai -> Arg ai $ var i) (downFrom m) ais -substBody :: (Subst t a) => Int -> Int -> t -> a -> a+substBody :: Subst a => Int -> Int -> SubstArg a -> a -> a substBody n m v = applySubst $ liftS n $ v :# raiseS m  instance PrecomputeFreeVars a => PrecomputeFreeVars (CompiledClauses' a) where

src/full/Agda/TypeChecking/CompiledClause/Match.hs view

@@ -13,6 +13,7 @@ import Agda.TypeChecking.Substitute  import Agda.Utils.Maybe+import Agda.Utils.Pretty (prettyShow)  import Agda.Utils.Impossible @@ -65,7 +66,7 @@     case c of        -- impossible case-      Fail -> no (NotBlocked AbsurdMatch) es+      Fail{} -> no (NotBlocked AbsurdMatch) es        -- done matching       Done xs t@@ -151,7 +152,7 @@             --    mo <- getBuiltinName' builtinIOne             --    return $ Set.fromList $ catMaybes [mi,mo] -            fallThrough <- return $ fromMaybe False (fallThrough bs) && isJust (catchAllBranch bs)+            fallThrough <- return $ (Just True ==) (fallThrough bs) && isJust (catchAllBranch bs)              let               isCon b =@@ -159,8 +160,7 @@                  Apply a | c@Con{} <- unArg a -> Just c                  _                            -> Nothing             -- Now do the matching on the @n@ths argument:-            id $-             case eb of+            case eb of               -- In case of a literal, try also its constructor form               NotBlocked _ (Apply (Arg info v@(Lit l))) -> performedSimplification $ do                 cv <- constructorForm v@@ -184,7 +184,6 @@               _ | fallThrough -> match' $ catchAllFrame $ stack                Blocked x _            -> no (Blocked x) es'-              NotBlocked _ (Apply (Arg info (MetaV x _))) -> no (Blocked x) es'                -- Otherwise, we are stuck.  If we were stuck before,               -- we keep the old reason, otherwise we give reason StuckOn here.@@ -199,5 +198,5 @@     then return (NoReduction $ NotBlocked MissingClauses [])     else do       traceSLn "impossible" 10-        ("Incomplete pattern matching when applying " ++ show f)+        ("Incomplete pattern matching when applying " ++ prettyShow f)         __IMPOSSIBLE__

src/full/Agda/TypeChecking/Constraints.hs view

@@ -5,10 +5,13 @@ import Prelude hiding (null)  import Control.Monad+import Control.Monad.Except  import qualified Data.List as List import qualified Data.Set as Set+import Data.Either +import Agda.Syntax.Common import Agda.Syntax.Internal  import Agda.TypeChecking.Monad@@ -21,14 +24,17 @@ import Agda.TypeChecking.MetaVars.Mention import Agda.TypeChecking.Warnings +import Agda.TypeChecking.Irrelevance import {-# SOURCE #-} Agda.TypeChecking.Rules.Application import {-# SOURCE #-} Agda.TypeChecking.Rules.Def import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Conversion import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Empty+import {-# SOURCE #-} Agda.TypeChecking.Lock -import Agda.Utils.Except ( MonadError(throwError) )+import Agda.Utils.CallStack ( withCurrentCallStack )+import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -37,7 +43,6 @@ import Agda.Utils.Impossible  instance MonadConstraint TCM where-  catchPatternErr           = catchPatternErrTCM   addConstraint             = addConstraintTCM   addAwakeConstraint        = addAwakeConstraint'   solveConstraint           = solveConstraintTCM@@ -47,38 +52,28 @@   modifyAwakeConstraints    = modifyTC . mapAwakeConstraints   modifySleepingConstraints = modifyTC . mapSleepingConstraints -catchPatternErrTCM :: TCM a -> TCM a -> TCM a-catchPatternErrTCM 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{} -> handle-         _            -> throwError err--addConstraintTCM :: Constraint -> TCM ()-addConstraintTCM c = do+addConstraintTCM :: Blocker -> Constraint -> TCM ()+addConstraintTCM unblock c = do       pids <- asksTC envActiveProblems       reportSDoc "tc.constr.add" 20 $ hsep         [ "adding constraint"-        , text (show $ Set.toList pids)-        , prettyTCM c ]+        , prettyTCM . PConstr pids unblock =<< buildClosure c ]       -- Need to reduce to reveal possibly blocking metas       c <- reduce =<< instantiateFull c-      caseMaybeM (simpl c) {-no-} (addConstraint' c) $ {-yes-} \ cs -> do+      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 . clValue . theConstraint)+         wakeConstraints' isWakeableInstanceConstraint     where-      isWakeableInstanceConstraint :: Constraint -> TCM Bool-      isWakeableInstanceConstraint = \case-        FindInstance _ b _ -> maybe (return True) isInstantiatedMeta b-        _ -> return False+      isWakeableInstanceConstraint :: ProblemConstraint -> WakeUp+      isWakeableInstanceConstraint c =+        case clValue $ theConstraint c of+          FindInstance{}+            | constraintUnblocker c == alwaysUnblock -> WakeUp+          _ -> DontWakeUp Nothing        isLvl LevelCmp{} = True       isLvl _          = False@@ -99,15 +94,20 @@           return $ simplifyLevelConstraint c $ map clValue lvlcs         | otherwise = return Nothing -wakeConstraintsTCM :: (ProblemConstraint-> TCM Bool) -> TCM ()+wakeConstraintsTCM :: (ProblemConstraint-> WakeUp) -> TCM () wakeConstraintsTCM wake = do   c <- useR stSleepingConstraints-  (wakeup, sleepin) <- partitionM wake c+  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)+  where+    checkWakeUp c = case wake c of+      WakeUp              -> Left c+      DontWakeUp Nothing  -> Right c+      DontWakeUp (Just u) -> Right c{ constraintUnblocker = u }  -- | Add all constraints belonging to the given problem to the current problem(s). stealConstraintsTCM :: ProblemId -> TCM ()@@ -115,14 +115,19 @@   current <- asksTC envActiveProblems   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 c) | Set.member pid pids = PConstr (Set.union current pids) c-                                 | otherwise           = pc+  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 + -- | Don't allow the argument to produce any 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)   => m a -> m a@@ -130,10 +135,24 @@   (pid, x) <- newProblem problem   cs <- getConstraintsForProblem pid   unless (null cs) $ do-    w <- warning_ (UnsolvedConstraints cs)-    typeError $ NonFatalErrors [ w ]+    withCurrentCallStack $ \loc -> do+      w <- warning'_ loc (UnsolvedConstraints cs)+      typeError' loc $ NonFatalErrors [ w ]   return x +-- | 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+  , MonadFresh ProblemId m+  , MonadTCEnv m+  , MonadWarning m+  ) => m a -> m a+nonConstraining = dontAssignMetas . noConstraints+ -- | Create a fresh problem for the given action. newProblem   :: (MonadFresh ProblemId m, MonadConstraint m)@@ -161,11 +180,10 @@  -- | @guardConstraint c blocker@ tries to solve @blocker@ first. --   If successful without constraints, it moves on to solve @c@, otherwise it---   adds a @Guarded c cs@ constraint---   to the @blocker@-generated constraints @cs@.+--   adds a @c@ to the constraint pool, blocked by the problem generated by @blocker@. guardConstraint :: Constraint -> TCM () -> TCM () guardConstraint c blocker =-  ifNoConstraints_ blocker (solveConstraint c) (addConstraint . Guarded c)+  ifNoConstraints_ blocker (solveConstraint c) (\ pid -> addConstraint (unblockOnProblem pid) c)  whenConstraints :: TCM () -> TCM () -> TCM () whenConstraints action handler =@@ -175,22 +193,26 @@  -- | Wake constraints matching the given predicate (and aren't instance --   constraints if 'shouldPostponeInstanceSearch').-wakeConstraints' :: (ProblemConstraint -> TCM Bool) -> TCM ()+wakeConstraints' :: (ProblemConstraint -> WakeUp) -> TCM () wakeConstraints' p = do   skipInstance <- shouldPostponeInstanceSearch-  wakeConstraints (\ c -> (&&) (not $ skipInstance && isInstanceConstraint (clValue $ theConstraint c)) <$> p c)+  let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c)+  wakeConstraints $ wakeUpWhen (not . skip) p  -- | Wake up the constraints depending on the given meta. wakeupConstraints :: MetaId -> TCM () wakeupConstraints x = do-  wakeConstraints' (return . mentionsMeta x)+  wakeConstraints' (wakeIfBlockedOnMeta x . constraintUnblocker)   solveAwakeConstraints --- | Wake up all constraints.+-- | Wake up all constraints not blocked on a problem. wakeupConstraints_ :: TCM () wakeupConstraints_ = do-  wakeConstraints' (return . const True)+  wakeConstraints' (wakeup . constraintUnblocker)   solveAwakeConstraints+  where+    wakeup u | Set.null $ allBlockingProblems u = WakeUp+             | otherwise                        = DontWakeUp Nothing  solveAwakeConstraints :: (MonadConstraint m) => m () solveAwakeConstraints = solveAwakeConstraints' False@@ -229,31 +251,24 @@ solveConstraint_ (ValueCmp cmp a u v)       = compareAs cmp a u v solveConstraint_ (ValueCmpOnFace cmp p a u v) = compareTermOnFace cmp p a u v solveConstraint_ (ElimCmp cmp fs a e u v)   = compareElims cmp fs a e u v-solveConstraint_ (TelCmp a b cmp tela telb) = compareTel a b cmp tela telb solveConstraint_ (SortCmp cmp s1 s2)        = compareSort cmp s1 s2 solveConstraint_ (LevelCmp cmp a b)         = compareLevel cmp a b-solveConstraint_ c0@(Guarded c pid)         = do-  ifM (isProblemSolved pid)-    {-then-} (do-      reportSLn "tc.constr.solve" 50 $ "Guarding problem " ++ show pid ++ " is solved, moving on..."-      solveConstraint_ c)-    {-else-} $ do-      reportSLn "tc.constr.solve" 50 $ "Guarding problem " ++ show pid ++ " is still unsolved."-      addConstraint c0 solveConstraint_ (IsEmpty r t)              = ensureEmptyType r t solveConstraint_ (CheckSizeLtSat t)         = checkSizeLtSat t-solveConstraint_ (UnquoteTactic _ tac hole goal) = unquoteTactic tac hole goal-solveConstraint_ (UnBlock m)                =-  ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (addConstraint $ UnBlock m) $ do+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+        reportSDoc "tc.constr.unblock" 15 $ hsep ["not unblocking", prettyTCM m, "because",+                                                  ifM (isFrozen m) "it's frozen" "meta assignments are turned off"]+        addConstraint alwaysUnblock $ UnBlock m) $ do     inst <- mvInstantiation <$> lookupMeta m-    reportSDoc "tc.constr.unblock" 15 $ text ("unblocking a metavar yields the constraint: " ++ show inst)+    reportSDoc "tc.constr.unblock" 65 $ text ("unblocking a metavar yields the constraint: " ++ show inst)     case inst of       BlockedConst t -> do         reportSDoc "tc.constr.blocked" 15 $           text ("blocked const " ++ prettyShow m ++ " :=") <+> prettyTCM t         assignTerm m [] t-      PostponedTypeCheckingProblem cl unblock -> enterClosure cl $ \prob -> do-        ifNotM unblock (addConstraint $ UnBlock m) $ do+      PostponedTypeCheckingProblem cl -> enterClosure cl $ \prob -> do           tel <- getContextTelescope           v   <- liftTCM $ checkTypeCheckingProblem prob           assignTerm m (telToArgs tel) v@@ -272,21 +287,23 @@       -- Open (whatever that means)       Open -> __IMPOSSIBLE__       OpenInstance -> __IMPOSSIBLE__-solveConstraint_ (FindInstance m b cands)     = findInstance m cands-solveConstraint_ (CheckFunDef d i q cs)       = withoutCache $+solveConstraint_ (FindInstance m cands) = findInstance m cands+solveConstraint_ (CheckFunDef d 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.   checkFunDef d i q cs-solveConstraint_ (HasBiggerSort a)            = hasBiggerSort a-solveConstraint_ (HasPTSRule a b)             = hasPTSRule a b-solveConstraint_ (CheckMetaInst m)            = checkMetaInst m+solveConstraint_ (CheckLockedVars a b c d)   = checkLockedVars a b c d+solveConstraint_ (HasBiggerSort a)      = hasBiggerSort a+solveConstraint_ (HasPTSRule a b)       = hasPTSRule a b+solveConstraint_ (CheckMetaInst m)      = checkMetaInst m+solveConstraint_ (UsableAtModality mod t) = usableAtModality mod t  checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term-checkTypeCheckingProblem p = case p of+checkTypeCheckingProblem = \case   CheckExpr cmp e t              -> checkExpr' cmp e t-  CheckArgs eh r args t0 t1 k    -> checkArguments eh r args t0 t1 k-  CheckProjAppToKnownPrincipalArg cmp e o ds args t k v0 pt ->-    checkProjAppToKnownPrincipalArg cmp e o ds args t k v0 pt+  CheckArgs cmp eh r args t0 t1 k -> checkArguments cmp eh r args t0 t1 k+  CheckProjAppToKnownPrincipalArg cmp e o ds args t k v0 pt patm ->+    checkProjAppToKnownPrincipalArg cmp e o ds args t k v0 pt patm   CheckLambda cmp args body target -> checkPostponedLambda cmp args body target   DoQuoteTerm cmp et t           -> doQuoteTerm cmp et t

src/full/Agda/TypeChecking/Constraints.hs-boot view

@@ -1,10 +1,12 @@ 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) import Agda.TypeChecking.Warnings (MonadWarning)--import Agda.Utils.Except (MonadError)  instance MonadConstraint TCM where

src/full/Agda/TypeChecking/Conversion.hs view

@@ -2,26 +2,25 @@  module Agda.TypeChecking.Conversion where -import Control.Arrow (first, second)+import Control.Arrow (second) import Control.Monad+import Control.Monad.Except+-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail)  import Data.Function+import Data.Semigroup ((<>)) import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntSet as IntSet -import Agda.Syntax.Abstract.Views (isSet) import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Translation.InternalToAbstract (reify)  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.MetaVars import Agda.TypeChecking.MetaVars.Occurs (killArgs,PruneResult(..),rigidVarsNotContainedIn) import Agda.TypeChecking.Names@@ -47,11 +46,13 @@ import Agda.TypeChecking.Warnings (MonadWarning) import Agda.Interaction.Options -import Agda.Utils.Except ( MonadError(catchError, throwError) ) import Agda.Utils.Functor+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.Utils.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.WithDefault@@ -59,19 +60,14 @@ import Agda.Utils.Impossible  type MonadConversion m =-  ( MonadReduce m-  , MonadAddContext m+  ( PureTCM m   , MonadConstraint m   , MonadMetaSolver m   , MonadError TCErr m   , MonadWarning m-  , MonadDebug m   , MonadStatistics m   , MonadFresh ProblemId m   , MonadFresh Int m-  , HasBuiltins m-  , HasConstInfo m-  , HasOptions m   , MonadFail m   ) @@ -110,6 +106,16 @@     areVars (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = Just $ n /= m -- prune different vars     areVars _ _                                   = Nothing +-- | 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'+    err@Exception{}     -> throwError err+    err@IOException{}   -> throwError err+ equalTerm :: MonadConversion m => Type -> Term -> Term -> m () equalTerm = compareTerm CmpEq @@ -141,7 +147,7 @@   -- 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-  reportSDoc "tc.conv.term" 10 $ sep $+  reportSDoc "tc.conv.term" 20 $ sep $     [ "compareTerm"     , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v     , nest 2 $ prettyTCM a@@ -184,6 +190,13 @@                              | otherwise = (assign rid y vs u, assign dir x us v)         (MetaV x us, _) -> unlessSubtyping $ assign dir x us v `orelse` fallback         (_, MetaV y vs) -> unlessSubtyping $ assign rid y vs u `orelse` fallback+        (Def f es, Def f' es') | f == f' ->+          ifNotM (optFirstOrder <$> pragmaOptions) fallback $ {- else -} unlessSubtyping $ do+          def <- getConstInfo f+          -- We do not shortcut projection-likes+          if isJust $ isProjection_ (theDef def) then fallback else do+          pol <- getPolarity' cmp f+          compareElims pol [] (defType def) (Def f []) es es' `orelse` fallback         _               -> fallback   where     assign :: CompareDirection -> MetaId -> Elims -> Term -> m ()@@ -193,7 +206,7 @@         [ "attempting shortcut"         , nest 2 $ prettyTCM (MetaV x es) <+> ":=" <+> prettyTCM v         ]-      whenM (isInstantiatedMeta x) patternViolation+      whenM (isInstantiatedMeta x) (patternViolation alwaysUnblock) -- Already instantiated, retry right away       assignE dir x es v a $ compareAsDir dir a       reportSDoc "tc.conv.term.shortcut" 50 $         "shortcut successful" $$ nest 2 ("result:" <+> (pretty =<< instantiate (MetaV x es)))@@ -226,7 +239,7 @@           comp w v         Nothing ->  do           reportSLn "tc.conv.assign" 30 "eta expansion did not instantiate meta"-          patternViolation  -- nothing happened, give up+          patternViolation (unblockOnAnyMetaIn (MetaV x es)) -- nothing happened, give up  compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m () compareAsDir dir a = dirToCmp (`compareAs'` a) dir@@ -240,20 +253,20 @@ compareTerm' :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m () compareTerm' cmp a m n =   verboseBracket "tc.conv.term" 20 "compareTerm" $ do-  a' <- reduce a-  (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: m () -> m ()) $ do+  (ba, a') <- reduceWithBlocker a+  (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: m () -> m ()) $ blockOnError ba $ do     reportSDoc "tc.conv.term" 30 $ fsep       [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' ]     propIrr  <- isPropEnabled     isSize   <- isJust <$> isSizeType a'-    s        <- reduce $ getSort a'+    (bs, s)  <- reduceWithBlocker $ getSort a'     mlvl     <- getBuiltin' builtinLevel     reportSDoc "tc.conv.level" 60 $ nest 2 $ sep       [ "a'   =" <+> pretty a'       , "mlvl =" <+> pretty mlvl       , text $ "(Just (unEl a') == mlvl) = " ++ show (Just (unEl a') == mlvl)       ]-    case s of+    blockOnError bs $ case s of       Prop{} | propIrr -> compareIrrelevant a' m n       _    | isSize   -> compareSizes cmp m n       _               -> case unEl a' of@@ -279,8 +292,9 @@                   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 _                   = return True-                  isMeta (NotBlocked _ MetaV{}) = True-                  isMeta _                      = False+                  isMeta b = case ignoreBlocking b of+                               MetaV{} -> True+                               _       -> False                reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> "is eta record type"               m <- reduceB m@@ -295,11 +309,9 @@                     -- Andreas 2011-03-23: (fixing issue 396)                     -- if we are dealing with a singleton record,                     -- we can succeed immediately-                    isSing <- isSingletonRecordModuloRelevance r ps-                    case isSing of-                      Right True -> return ()+                    ifM (isSingletonRecordModuloRelevance r ps) (return ()) $                       -- do not eta-expand if comparing two neutrals-                      _ -> compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)+                      compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)                 _ -> do                   (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m                   (_  , n') <- etaExpandRecord r ps $ ignoreBlocking n@@ -332,7 +344,7 @@         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'+        addContext (name, defaultDom interval) $ 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@@ -341,21 +353,23 @@        mGlue  <- getPrimitiveName' builtinGlue        mHComp <- getPrimitiveName' builtinHComp        mSub   <- getBuiltinName' builtinSub+       mUnglueU <- getPrimitiveTerm' builtin_unglueU+       mSubIn   <- getPrimitiveTerm' 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-              ty <- el' (pure $ unArg l) (pure $ unArg a)+              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 (ty,mkUnglue m,mkUnglue n)-              compareTermOnFace cmp (unArg phi) ty m n-              compareTerm cmp ty (mkUnglue m) (mkUnglue n)+              reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n)+              compareTermOnFace cmp (unArg phi) a' m n+              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 -> do+                  , Sort (Type lvl) <- unArg s+                  , Just unglueU <- mUnglueU, Just subIn <- mSubIn+                  -> do               let l = Level lvl               ty <- el' (pure $ l) (pure $ unArg u0)-              unglueU <- prim_unglueU-              subIn <- primSubIn               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)@@ -369,25 +383,6 @@          Def q [] | Just q == mI -> compareInterval cmp a' m n          _ -> compareAtom cmp (AsTermsOf a') m n --- | @compareTel t1 t2 cmp tel1 tel1@ checks whether pointwise---   @tel1 \`cmp\` tel2@ and complains that @t2 \`cmp\` t1@ failed if---   not.-compareTel :: MonadConversion m => Type -> Type ->-  Comparison -> Telescope -> Telescope -> m ()-compareTel t1 t2 cmp tel1 tel2 =-  verboseBracket "tc.conv.tel" 20 "compareTel" $-  catchConstraint (TelCmp t1 t2 cmp tel1 tel2) $ case (tel1, tel2) of-    (EmptyTel, EmptyTel) -> return ()-    (EmptyTel, _)        -> bad-    (_, EmptyTel)        -> bad-    (ExtendTel dom1{-@(Dom i1 a1)-} tel1, ExtendTel dom2{-@(Dom i2 a2)-} tel2) -> do-      compareDom cmp dom1 dom2 tel1 tel2 bad bad bad bad $-        compareTel t1 t2 cmp (absBody tel1) (absBody tel2)-  where-    -- Andreas, 2011-05-10 better report message about types-    bad = typeError $ UnequalTypes cmp t2 t1-      -- switch t2 and t1 because of contravariance!- compareAtomDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m () compareAtomDir dir a = dirToCmp (`compareAtom` a) dir @@ -414,7 +409,8 @@     -- Andreas, 2016-02-09, Issue 1825: The type of arg might be     -- a meta-variable, e.g. in interactive development.     -- In this case, we postpone.-    fromMaybeM patternViolation $ getDefType f =<< reduce targ+    targ <- abortIfBlocked targ+    fromMaybeM __IMPOSSIBLE__ $ getDefType f targ  -- | Syntax directed equality on atomic values --@@ -423,6 +419,7 @@   verboseBracket "tc.conv.atom" 20 "compareAtom" $   -- if a PatternErr is thrown, rebuild constraint!   (catchConstraint (ValueCmp cmp t m n) :: m () -> m ()) $ 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                              , prettyTCM n@@ -430,10 +427,14 @@                              ]     -- Andreas: what happens if I cut out the eta expansion here?     -- Answer: Triggers issue 245, does not resolve 348-    (mb',nb') <- ifM (asksTC envCompareBlocked) ((notBlocked -*- notBlocked) <$> reduce (m,n)) $ do+    (mb',nb') <- do       mb' <- etaExpandBlocked =<< reduceB m       nb' <- etaExpandBlocked =<< reduceB n       return (mb', nb')+    let getBlocker (Blocked b _) = b+        getBlocker NotBlocked{}  = neverUnblock+        blocker = unblockOnEither (getBlocker mb') (getBlocker nb')+    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@@ -450,21 +451,9 @@     let m = ignoreBlocking mb         n = ignoreBlocking nb -        postpone = addConstraint $ ValueCmp cmp t m n--        -- Jesper, 2019-05-14, Issue #3776: If the type is blocked,-        -- the comparison could be solved by eta-expansion so we-        -- cannot fail hard-        postponeIfBlockedAs :: CompareAs -> (Blocked CompareAs -> m ()) -> m ()-        postponeIfBlockedAs AsTypes       f = f $ NotBlocked ReallyNotBlocked AsTypes-        postponeIfBlockedAs AsSizes       f = f $ NotBlocked ReallyNotBlocked AsSizes-        postponeIfBlockedAs (AsTermsOf t) f = ifBlocked t-          (\m t -> (f $ Blocked m $ AsTermsOf t) `catchError` \case-              TypeError{} -> postpone-              err         -> throwError err)-          (\nb t -> f $ NotBlocked nb $ AsTermsOf t)+        checkDefinitionalEquality = unlessM (pureCompareAs CmpEq t m n) notEqual -        checkDefinitionalEquality = unlessM (pureCompareAs CmpEq t m n) postpone+        notEqual = typeError $ UnequalTerms cmp m n t          dir = fromCmp cmp         rid = flipCmp dir     -- The reverse direction.  Bad name, I know.@@ -483,11 +472,13 @@     case (mb, nb) of       -- equate two metas x and y.  if y is the younger meta,       -- try first y := x and then x := y-      (NotBlocked _ (MetaV x xArgs), NotBlocked _ (MetaV y yArgs))-          | x == y , cmpBlocked -> do+      _ | MetaV x xArgs <- ignoreBlocking mb,   -- Can be either Blocked or NotBlocked depending on+          MetaV y yArgs <- ignoreBlocking nb -> -- envCompareBlocked check above.+        if | x == y, cmpBlocked -> do               a <- metaType x-              compareElims [] [] a (MetaV x []) xArgs yArgs-          | x == y ->+              blockOnError (unblockOnMeta x) $+                compareElims [] [] a (MetaV x []) xArgs yArgs+           | x == y -> blockOnError (unblockOnMeta x) $             case intersectVars xArgs yArgs of               -- all relevant arguments are variables               Just kills -> do@@ -496,12 +487,12 @@                 case killResult of                   NothingToPrune   -> return ()                   PrunedEverything -> return ()-                  PrunedNothing    -> postpone-                  PrunedSomething  -> postpone+                  PrunedNothing    -> checkDefinitionalEquality+                  PrunedSomething  -> checkDefinitionalEquality               -- not all relevant arguments are variables               Nothing -> checkDefinitionalEquality -- Check definitional equality on meta-variables                               -- (same as for blocked terms)-          | otherwise -> do+           | otherwise -> do               [p1, p2] <- mapM getMetaPriority [x,y]               -- First try the one with the highest priority. If that doesn't               -- work, try the low priority one.@@ -515,15 +506,16 @@                           l2 = ifM (isInstantiatedMeta x) (compareAsDir dir t m n) l1                           r2 = ifM (isInstantiatedMeta y) (compareAsDir rid t n m) r1 -              catchPatternErr solve2 solve1+              -- Unblock on both unblockers of solve1 and solve2+              catchPatternErr (`addOrUnblocker` solve2) solve1 -      -- one side a meta, the other an unblocked term-      (NotBlocked _ (MetaV x es), _) -> assign dir x es n-      (_, NotBlocked _ (MetaV x es)) -> assign rid x es m-      (Blocked{}, Blocked{})  -> checkDefinitionalEquality-      (Blocked{}, _)  -> useInjectivity (fromCmp cmp) t m n   -- The blocked term goes first-      (_, Blocked{})  -> useInjectivity (flipCmp $ fromCmp cmp) t n m-      _ -> postponeIfBlockedAs t $ \bt -> do+      -- 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+      _ -> blockOnError blocker $ do         -- -- Andreas, 2013-10-20 put projection-like function         -- -- into the spine, to make compareElims work.         -- -- 'False' means: leave (Def f []) unchanged even for@@ -582,7 +574,7 @@                   -- Constructors are covariant in their arguments                   -- (see test/succeed/CovariantConstructors).                   compareElims (repeat $ polFromCmp cmp) forcedArgs a' (Con x ci []) xArgs yArgs-          _ -> typeError $ UnequalTerms cmp m n $ ignoreBlocking bt+          _ -> notEqual     where         -- returns True in case we handled the comparison already.         compareEtaPrims :: MonadConversion m => QName -> Elims -> Elims -> m Bool@@ -605,9 +597,9 @@               -- since b and b' should be neutral terms, but it's a               -- precondition for the compareAtom call to make               -- sense.-              equalType (El Inf $ apply tSub $ [a] ++ map (setHiding NotHidden) [bA,phi,u])-                        (El Inf $ apply tSub $ [a] ++ map (setHiding NotHidden) [bA',phi',u'])-              compareAtom cmp (AsTermsOf $ El Inf $ 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'               return True@@ -650,7 +642,8 @@               return True             _  -> return False         -- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked-        conType c t = ifBlocked t (\ _ _ -> patternViolation) $ \ _ t -> do+        conType c t = do+          t <- abortIfBlocked t           let impossible = do                 reportSDoc "impossible" 10 $                   "expected data/record type, found " <+> prettyTCM t@@ -661,7 +654,7 @@                 -- In issue 921, this happens during the final attempt                 -- to solve left-over constraints.                 -- Thus, instead of crashing, just give up gracefully.-                patternViolation+                patternViolation neverUnblock           maybe impossible (return . snd) =<< getFullyAppliedConType c t         equalFun t1 t2 = case (t1, t2) of           (Pi dom1 b1, Pi dom2 b2) -> do@@ -780,20 +773,22 @@     -- (Note that @patternViolation@ swallows exceptions coming from @getConType@     -- thus, we would not see clearly if we used @getFullyAppliedConType@ instead.)     (Con x ci us, Con y _ vs) | x == y -> maybeGiveUp $ do-      a <- maybe patternViolation (return . snd) =<< getConType x a+      a <- maybe abort (return . snd) =<< getConType x a       antiUnifyElims pid a (Con x ci []) us vs+    (Def f [], Def g []) | f == g -> return (Def f [])     (Def f us, Def g vs) | f == g, length us == length vs -> maybeGiveUp $ do       a <- computeElimHeadType f us vs       antiUnifyElims pid a (Def f []) us vs     _ -> fallback   where-    maybeGiveUp = catchPatternErr fallback-+    maybeGiveUp = catchPatternErr $ \ _ -> fallback+    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 pid dom u v-  | getModality u /= getModality v = patternViolation+  | not (sameModality (getModality u) (getModality v))+              = patternViolation neverUnblock   | otherwise = applyModalityToContext u $     ifM (isIrrelevantOrPropM dom)     {-then-} (return u)@@ -808,19 +803,21 @@   res <- projectTyped self a o f   case res of     Just (_, self, a) -> antiUnifyElims pid a self es1 es2-    Nothing -> patternViolation -- can fail for projection like+    Nothing -> patternViolation neverUnblock -- can fail for projection like antiUnifyElims pid a self (Apply u : es1) (Apply v : es2) = do   reduce (unEl a) >>= \case     Pi a b -> do       w <- antiUnifyArgs pid a u v       antiUnifyElims pid (b `lazyAbsApp` unArg w) (apply self [w]) es1 es2-    _ -> patternViolation-antiUnifyElims _ _ _ _ _ = patternViolation -- trigger maybeGiveUp in antiUnify+    _ -> patternViolation neverUnblock+antiUnifyElims _ _ _ _ _ = patternViolation neverUnblock -- trigger maybeGiveUp in antiUnify  -- | @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 = (catchConstraint (ElimCmp pols0 fors0 a v els01 els02) :: m () -> m ()) $ do+compareElims pols0 fors0 a v els01 els02 =+  verboseBracket "tc.conv.elim" 20 "compareElims" $+  (catchConstraint (ElimCmp pols0 fors0 a v els01 els02) :: m () -> m ()) $ do   let v1 = applyE v els01       v2 = applyE v els02       failure = typeError $ UnequalTerms CmpEq v1 v2 (AsTermsOf a)@@ -854,25 +851,25 @@       reportSDoc "tc.conv.elim" 25 $ "compareElims IApply"        -- Andrea: copying stuff from the Apply case..       let (pol, pols) = nextPolarity pols0-      ifBlocked a (\ m t -> patternViolation) $ \ _ a -> do-          va <- pathView a-          reportSDoc "tc.conv.elim.iapply" 60 $ "compareElims IApply" $$ do-            nest 2 $ "va =" <+> text (show (isPathType va))-          case va of-            PathType s path l bA x y -> do-              b <- elInf primInterval-              compareWithPol pol (flip compareTerm b)-                                  r1 r2-              -- TODO: compare (x1,x2) and (y1,y2) ?-              let r = r1 -- TODO Andrea:  do blocking-              codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r)-              compareElims pols [] codom -- Path non-dependent (codom `lazyAbsApp` unArg arg)-                                (applyE v [e]) els1 els2-            -- We allow for functions (i : I) -> ... to also be heads of a IApply,-            -- because @etaContract@ can produce such terms-            OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v (Apply (defaultArg r1) : els1) (Apply (defaultArg r2) : els2)+      a  <- abortIfBlocked a+      va <- pathView a+      reportSDoc "tc.conv.elim.iapply" 60 $ "compareElims IApply" $$ do+        nest 2 $ "va =" <+> text (show (isPathType va))+      case va of+        PathType s path l bA x y -> do+          b <- primIntervalType+          compareWithPol pol (flip compareTerm b)+                              r1 r2+          -- TODO: compare (x1,x2) and (y1,y2) ?+          let r = r1 -- TODO Andrea:  do blocking+          codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r)+          compareElims pols [] codom -- Path non-dependent (codom `lazyAbsApp` unArg arg)+                            (applyE v [e]) els1 els2+        -- We allow for functions (i : I) -> ... to also be heads of a IApply,+        -- because @etaContract@ can produce such terms+        OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v (Apply (defaultArg r1) : els1) (Apply (defaultArg r2) : els2) -            OType{} -> patternViolation+        OType t -> patternViolation (unblockOnAnyMetaIn t) -- Can we get here? We know a is not blocked.      (Apply arg1 : els1, Apply arg2 : els2) ->       (verboseBracket "tc.conv.elim" 20 "compare Apply" :: m () -> m ()) $ do@@ -891,77 +888,78 @@         ]       let (pol, pols) = nextPolarity pols0           (for, fors) = nextIsForced fors0-      ifBlocked a (\ m t -> patternViolation) $ \ _ a -> do-        reportSLn "tc.conv.elim" 90 $ "type is not blocked"-        case unEl a of-          (Pi (Dom{domInfo = info, unDom = b}) codom) -> do-            reportSLn "tc.conv.elim" 90 $ "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+      a <- abortIfBlocked a+      reportSLn "tc.conv.elim" 40 $ "type is not blocked"+      case unEl a of+        (Pi (Dom{domInfo = info, unDom = b}) codom) -> do+          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 -            -- compare arg1 and arg2-            pid <- newProblem_ $ applyModalityToContext info $-                if isForced for then-                  reportSLn "tc.conv.elim" 90 $ "argument is forced"-                else if isIrrelevant info then do-                  reportSLn "tc.conv.elim" 90 $ "argument is irrelevant"-                  compareIrrelevant b (unArg arg1) (unArg arg2)-                else do-                  reportSLn "tc.conv.elim" 90 $ "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" 90 $ "solved = " ++ show solved-            arg <- if dependent && not solved-                   then applyModalityToContext info $ do-                    reportSDoc "tc.conv.elims" 30 $ 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" 30 $ 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" 90 $ "stealing constraints from problem " ++ show pid-            stealConstraints pid-            {- Stealing solves this issue:+          -- compare arg1 and arg2+          pid <- newProblem_ $ applyModalityToContext info $+              if isForced for then+                reportSLn "tc.conv.elim" 40 $ "argument is forced"+              else if isIrrelevant info then do+                reportSLn "tc.conv.elim" 40 $ "argument is irrelevant"+                compareIrrelevant b (unArg arg1) (unArg arg2)+              else 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: -               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.-            -}-          a -> do-            reportSDoc "impossible" 10 $-              "unexpected type when comparing apply eliminations " <+> prettyTCM a-            reportSDoc "impossible" 50 $ "raw type:" <+> pretty a-            patternViolation-            -- Andreas, 2013-10-22-            -- in case of disabled reductions (due to failing termination check)-            -- we might get stuck, so do not crash, but fail gently.-            -- __IMPOSSIBLE__+             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.+          -}+        a -> do+          reportSDoc "impossible" 10 $+            "unexpected type when comparing apply eliminations " <+> prettyTCM a+          reportSDoc "impossible" 50 $ "raw type:" <+> pretty a+          patternViolation (unblockOnAnyMetaIn a)+          -- Andreas, 2013-10-22+          -- in case of disabled reductions (due to failing termination check)+          -- we might get stuck, so do not crash, but fail gently.+          -- __IMPOSSIBLE__      -- case: f == f' are projections     (Proj o f : els1, Proj _ f' : els2)-      | f /= f'   -> typeError . GenericError . show =<< prettyTCM f <+> "/=" <+> prettyTCM f'-      | otherwise -> ifBlocked a (\ m t -> patternViolation) $ \ _ a -> do+      | f /= f'   -> typeError . GenericDocError =<< prettyTCM f <+> "/=" <+> prettyTCM 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           Just (_, u, t) -> do@@ -972,11 +970,11 @@             compareElims [] [] t u els1 els2           Nothing -> do             reportSDoc "tc.conv.elims" 30 $ sep-              [ text $ "projection " ++ show f+              [ text $ "projection " ++ prettyShow f               , text   "applied to value " <+> prettyTCM v               , text   "of unexpected type " <+> prettyTCM a               ]-            patternViolation+            patternViolation (unblockOnAnyMetaIn a)   -- | "Compare" two terms in irrelevant position.  This always succeeds.@@ -1017,7 +1015,7 @@         -- Andreas, 2016-08-08, issue #2131:         -- Mining for solutions for irrelevant metas is not definite.         -- Thus, in case of error, leave meta unsolved.-        else (assignE DirEq x es w (AsTermsOf t) $ compareIrrelevant t) `catchError` \ _ -> fallback+        else assignE DirEq x es w (AsTermsOf t) (compareIrrelevant t) `catchError` \ _ -> fallback         -- the value of irrelevant or unused meta does not matter     try v w fallback = fallback @@ -1052,10 +1050,6 @@           , hsep [ "   sorts:", prettyTCM s1, " and ", prettyTCM s2 ]           ]         compareAs cmp AsTypes a1 a2-        unlessM ((optCumulativity <$> pragmaOptions) `or2M`-                 (not . optCompareSorts <$> pragmaOptions)) $-          compareSort CmpEq s1 s2-        return ()  leqType :: MonadConversion m => Type -> Type -> m () leqType = compareType CmpLeq@@ -1070,7 +1064,7 @@ coerce cmp v t1 t2 = blockTerm t2 $ do   verboseS "tc.conv.coerce" 10 $ do     (a1,a2) <- reify (t1,t2)-    let dbglvl = if isSet a1 && isSet a2 then 50 else 10+    let dbglvl = 30     reportSDoc "tc.conv.coerce" dbglvl $       "coerce" <+> vcat         [ "term      v  =" <+> prettyTCM v@@ -1177,7 +1171,7 @@ leqSort :: forall m. MonadConversion m => Sort -> Sort -> m () leqSort s1 s2 = (catchConstraint (SortCmp CmpLeq s1 s2) :: m () -> m ()) $ do   (s1,s2) <- reduce (s1,s2)-  let postpone = addConstraint (SortCmp CmpLeq s1 s2)+  let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) (SortCmp CmpLeq s1 s2)       no       = typeError $ NotLeqSort s1 s2       yes      = return ()       synEq    = ifNotM (optSyntacticEquality <$> pragmaOptions) postpone $ do@@ -1190,6 +1184,8 @@                         , prettyTCM s2 ]         ]   propEnabled <- isPropEnabled+  typeInTypeEnabled <- typeInType+  omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions    let fvsRHS = (`IntSet.member` allFreeVars s2)   badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS@@ -1205,16 +1201,38 @@       -- Likewise for @Prop@       (Prop a  , Prop b  ) -> leqLevel a b +      -- Likewise for @SSet@+      (SSet a  , SSet b  ) -> leqLevel a b+       -- @Prop l@ is below @Set l@       (Prop a  , Type b  ) -> leqLevel a b       (Type a  , Prop b  ) -> no -      -- Setω is the top sort-      (_       , Inf     ) -> yes-      (Inf     , _       ) -> equalSort s1 s2+      -- @Setωᵢ@ is above all small sorts (spelling out all cases+      -- for the exhaustiveness checker)+      (Inf f m , Inf f' n) ->+        if leqFib f f' && (m <= n || typeInTypeEnabled || omegaInOmegaEnabled) then yes else no+      (Type{}  , Inf f _) -> yes+      (Prop{}  , Inf f _) -> yes+      (Inf f _, Type{}  ) -> if f == IsFibrant && typeInTypeEnabled then yes else no+      (Inf f _, SSet{}  ) -> if f == IsStrict  && typeInTypeEnabled then yes else no+      (Inf _ _, Prop{}  ) -> no +      -- @Set l@ is below @SSet l@+      (Type a  , SSet b  ) -> leqLevel a b+      (SSet a  , Type b  ) -> no++      -- @Prop l@ is below @SSet l@+      (Prop a  , SSet b  ) -> leqLevel a b+      (SSet a  , Prop b  ) -> no++      -- @SSet@ is below @SSetω@+      (SSet{}  , Inf IsStrict _) -> yes+      (SSet{}  , Inf IsFibrant _) -> no+       -- @SizeUniv@ and @Prop0@ are bottom sorts.       -- So is @Set0@ if @Prop@ is not enabled.+      (_       , LockUniv) -> equalSort s1 s2       (_       , SizeUniv) -> equalSort s1 s2       (_       , Prop (Max 0 [])) -> equalSort s1 s2       (_       , Type (Max 0 []))@@ -1223,13 +1241,17 @@       -- SizeUniv is unrelated to any @Set l@ or @Prop l@       (SizeUniv, Type{}  ) -> no       (SizeUniv, Prop{}  ) -> no--      -- If the first sort rigidly depends on a variable and the second-      -- sort does not mention this variable, the second sort must be Inf.-      (_       , _       ) | badRigid -> equalSort s2 Inf+      (SizeUniv , Inf{}  ) -> no+      (SizeUniv, SSet{}  ) -> no+      (LockUniv, Type{}  ) -> no+      (LockUniv, Prop{}  ) -> no+      (LockUniv , Inf{}  ) -> no+      (LockUniv, SSet{}  ) -> no -      -- This shouldn't be necessary-      (UnivSort Inf , UnivSort Inf) -> yes+      -- If the first sort is a small sort that rigidly depends on a+      -- variable and the second sort does not mention this variable,+      -- the second sort must be at least @Setω@.+      (_       , _       ) | Just (True,f) <- isSmallSort s1 , badRigid -> leqSort (Inf f 0) s2        -- PiSort, FunSort, UnivSort and MetaS might reduce once we instantiate       -- more metas, so we postpone.@@ -1247,6 +1269,9 @@       (_      , DefS{}) -> synEq    where+  leqFib IsFibrant _ = True+  leqFib IsStrict IsStrict = True+  leqFib _ _ = False   impossibleSort s = do     reportS "impossible" 10       [ "leqSort: found dummy sort with description:"@@ -1255,51 +1280,54 @@     __IMPOSSIBLE__  leqLevel :: MonadConversion m => Level -> Level -> m ()-leqLevel a b = do-  reportSDoc "tc.conv.nat" 30 $-    "compareLevel" <+>-      sep [ prettyTCM a <+> "=<"-          , prettyTCM b ]-  -- Andreas, 2015-12-28 Issue 1757-  -- We normalize both sides to make the syntactic equality check (==) stronger.-  -- See case for `same term` below.-  a <- normalise a-  b <- normalise b-  leqView a b-  where-    -- Andreas, 2016-09-28-    -- If we have to postpone a constraint, then its simplified form!-    leqView :: MonadConversion m => Level -> Level -> m ()-    leqView a b = catchConstraint (LevelCmp CmpLeq a b) $ do+leqLevel a b = catchConstraint (LevelCmp CmpLeq a b) $ do       reportSDoc "tc.conv.level" 30 $-        "compareLevelView" <+>-          sep [ pretty a <+> "=<"-              , pretty b ]+        "compareLevel" <+>+          sep [ prettyTCM a <+> "=<"+              , prettyTCM b ]++      (a, b) <- reduce (a, b)+      ((a, b), equal) <- SynEq.checkSyntacticEquality a b++      let notok    = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b)+          postpone = patternViolation (unblockOnAnyMetaIn (a, b))++          wrap m = m `catchError` \case+            TypeError{} -> notok+            err         -> throwError err++      reportSDoc "tc.conv.level" 60 $+        "checkSyntacticEquality returns" <+> prettyTCM equal+      unless equal $ do+       cumulativity <- optCumulativity <$> pragmaOptions+      areWeComputingOverlap <- viewTC eConflComputingOverlap       reportSDoc "tc.conv.level" 40 $         "compareLevelView" <+>-          sep [ prettyList_ (map (pretty . unSingleLevel) $ NonEmpty.toList $ levelMaxView a)+          sep [ prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView a               , "=<"-              , prettyList_ (map (pretty . unSingleLevel) $ NonEmpty.toList $ levelMaxView b)+              , prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView b               ]-      wrap $ case (levelMaxView a, levelMaxView b) of -        -- same term-        _ | a == b -> ok+      -- Extra reduce on level atoms, but should be cheap since they are already reduced.+      aB <- mapM reduceB a+      bB <- mapM reduceB b +      wrap $ case (levelMaxView aB, levelMaxView bB) of+         -- 0 ≤ any-        (SingleClosed 0 :| [] , _) -> ok+        (SingleClosed 0 :| [] , _) -> return ()          -- any ≤ 0         (as , SingleClosed 0 :| []) ->-          sequence_ [ equalLevel (unSingleLevel a') (ClosedLevel 0) | a' <- NonEmpty.toList as ]+          forM_ as $ \ a' -> equalLevel (unSingleLevel $ fmap ignoreBlocking a') (ClosedLevel 0)          -- closed ≤ closed-        (SingleClosed m :| [], SingleClosed n :| []) -> if m <= n then ok else notok+        (SingleClosed m :| [], SingleClosed n :| []) -> unless (m <= n) notok          -- closed ≤ b         (SingleClosed m :| [] , _)-          | m <= levelLowerBound b -> ok+          | m <= levelLowerBound b -> return ()          -- as ≤ neutral/closed         (as, bs)@@ -1307,22 +1335,23 @@          -- ⊔ as ≤ single         (as@(_:|_:_), b :| []) ->-          sequence_ [ leqView (unSingleLevel a') (unSingleLevel b) | a' <- NonEmpty.toList as ]+          forM_ as $ \ a' -> leqLevel (unSingleLevel $ ignoreBlocking <$> a')+                                      (unSingleLevel $ ignoreBlocking <$> b)          -- reduce constants         (as, bs)           | let minN = min (fst $ levelPlusView a) (fst $ levelPlusView b)                 a'   = fromMaybe __IMPOSSIBLE__ $ subLevel minN a                 b'   = fromMaybe __IMPOSSIBLE__ $ subLevel minN b-          , minN > 0 -> leqView a' b'+          , minN > 0 -> leqLevel a' b'          -- remove subsumed         -- Andreas, 2014-04-07: This is ok if we do not go back to equalLevel         (as, bs)-          | (subsumed@(_:_) , as') <- List.partition isSubsumed (NonEmpty.toList as)-          -> leqView (unSingleLevels as') b+          | (subsumed@(_:_) , as') <- List1.partition (isSubsumed . fmap ignoreBlocking) as+          -> leqLevel (unSingleLevels $ (fmap . fmap) ignoreBlocking as') b           where-            isSubsumed a = any (`subsumes` a) (NonEmpty.toList bs)+            isSubsumed a = any (`subsumes` a) $ (fmap . fmap) ignoreBlocking bs              subsumes :: SingleLevel -> SingleLevel -> Bool             subsumes (SingleClosed m)        (SingleClosed n)        = m >= n@@ -1335,13 +1364,14 @@         -- (where _l' is a new metavariable)         (as , bs)           | cumulativity-          , Just (mb@(MetaLevel x es) , bs') <- singleMetaView (NonEmpty.toList bs)+          , not areWeComputingOverlap+          , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map . fmap) ignoreBlocking (List1.toList bs)           , null bs' || noMetas (Level a , unSingleLevels bs') -> do             mv <- lookupMeta x             -- Jesper, 2019-10-13: abort if this is an interaction             -- meta or a generalizable meta             abort <- (isJust <$> isInteractionMeta x) `or2M`-                     ((== YesGeneralize) <$> isGeneralizableMeta x)+                     ((== YesGeneralizeVar) <$> isGeneralizableMeta x)             if | abort -> postpone                | otherwise -> do                   x' <- case mvJudgement mv of@@ -1353,7 +1383,7 @@                     [ "attempting to solve" , prettyTCM (MetaV x es) , "to the maximum of"                     , prettyTCM (Level a) , "and the fresh meta" , prettyTCM (MetaV x' es)                     ]-                  equalLevel (atomicLevel mb) $ levelLub a (atomicLevel $ MetaLevel x' es)+                  equalLevel (atomicLevel mb) $ levelLub a (atomicLevel $ MetaV x' es)           -- Andreas, 2016-09-28: This simplification loses the solution lzero.@@ -1366,43 +1396,27 @@         --   -- subsumed terms from the lhs.          -- anything else-        _ | noMetas (Level a , Level b) -> notok-          | otherwise                   -> postpone+        _ | noMetas (a, b) -> notok+          | otherwise      -> postpone       where-        ok       = return ()-        notok    = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b)-        postpone = patternViolation--        wrap m = m `catchError` \case-            TypeError{} -> notok-            err         -> throwError err--        neutralOrClosed (SingleClosed _)                     = True-        neutralOrClosed (SinglePlus (Plus _ NeutralLevel{})) = True-        neutralOrClosed _                                    = False+        neutralOrClosed (SingleClosed _)                   = True+        neutralOrClosed (SinglePlus (Plus _ NotBlocked{})) = True+        neutralOrClosed _                                  = False -        -- Is there exactly one @MetaLevel@ in the list of single levels?-        singleMetaView :: [SingleLevel] -> Maybe (LevelAtom, [SingleLevel])-        singleMetaView (SinglePlus (Plus 0 l@(MetaLevel m es)) : ls)+        -- Is there exactly one @MetaV@ in the list of single levels?+        singleMetaView :: [SingleLevel] -> Maybe (Term, [SingleLevel])+        singleMetaView (SinglePlus (Plus 0 l@(MetaV m es)) : ls)           | all (not . isMetaLevel) ls = Just (l,ls)         singleMetaView (l : ls)           | not $ isMetaLevel l = second (l:) <$> singleMetaView ls         singleMetaView _ = Nothing          isMetaLevel :: SingleLevel -> Bool-        isMetaLevel (SinglePlus (Plus _ MetaLevel{})) = True-        isMetaLevel (SinglePlus (Plus _ UnreducedLevel{})) = __IMPOSSIBLE__-        isMetaLevel _ = False+        isMetaLevel (SinglePlus (Plus _ MetaV{})) = True+        isMetaLevel _                             = False -equalLevel :: MonadConversion m => Level -> Level -> m ()+equalLevel :: forall m. MonadConversion m => Level -> Level -> m () equalLevel a b = do-  -- Andreas, 2013-10-31 Use normalization to make syntactic equality stronger-  (a, b) <- normalise (a, b)-  equalLevel' a b---- | Precondition: levels are 'normalise'd.-equalLevel' :: forall m. MonadConversion m => Level -> Level -> m ()-equalLevel' a b = do   reportSDoc "tc.conv.level" 50 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ]   -- Andreas, 2013-10-31 remove common terms (that don't contain metas!)   -- THAT's actually UNSOUND when metas are instantiated, because@@ -1421,9 +1435,22 @@                ]         ] +  (a, b) <- reduce (a, b)+  ((a, b), equal) <- SynEq.checkSyntacticEquality a b+  reportSDoc "tc.conv.level" 60 $+    "checkSyntacticEquality returns" <+> prettyTCM equal+  unless equal $ do+   -- Jesper, 2014-02-02 remove terms that certainly do not contribute   -- to the maximum-  let (a',b') = removeSubsumed a b+  let (a', b') = removeSubsumed a b++  let notok    = unlessM typeInType notOk+      notOk    = typeError $ UnequalLevel CmpEq a' b'+      postpone = do+        reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a' <+> "==") 0 (pretty b')+        patternViolation (unblockOnAnyMetaIn (a', b'))+   reportSDoc "tc.conv.level" 50 $     sep [ "equalLevel (w/o subsumed)"         , vcat [ nest 2 $ sep [ prettyTCM a' <+> "=="@@ -1436,30 +1463,31 @@       bs  = levelMaxView b'   reportSDoc "tc.conv.level" 50 $     sep [ text "equalLevel"-        , vcat [ nest 2 $ sep [ prettyList_ (map (pretty . unSingleLevel) $ NonEmpty.toList $ as)+        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as                               , "=="-                              , prettyList_ (map (pretty . unSingleLevel) $ NonEmpty.toList $ bs)+                              , prettyList_ $ fmap (pretty . unSingleLevel) bs                               ]                ]         ]    reportSDoc "tc.conv.level" 80 $     sep [ text "equalLevel"-        , vcat [ nest 2 $ sep [ prettyList_ (map (text . show . unSingleLevel) $ NonEmpty.toList $ as)+        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (text . show . unSingleLevel) as                               , "=="-                              , prettyList_ (map (text . show . unSingleLevel) $ NonEmpty.toList $ bs)+                              , prettyList_ $ fmap (text . show . unSingleLevel) bs                               ]                ]         ] -  catchConstraint (LevelCmp CmpEq a b) $ case (as, bs) of+  -- Extra reduce on level atoms, but should be cheap since they are already reduced.+  as <- (mapM . mapM) reduceB as+  bs <- (mapM . mapM) reduceB bs -        -- equal levels-        _ | a == b -> ok+  catchConstraint (LevelCmp CmpEq a b) $ case (as, bs) of          -- closed == closed         (SingleClosed m :| [], SingleClosed n :| [])-          | m == n    -> ok+          | m == n    -> return ()           | otherwise -> notok          -- closed == neutral@@ -1472,24 +1500,24 @@          -- 0 == a ⊔ b         (SingleClosed 0 :| [] , bs@(_:|_:_)) ->-          sequence_ [ equalLevel' (ClosedLevel 0) (unSingleLevel b') | b' <- NonEmpty.toList bs ]+          forM_ bs $ \ b' ->  equalLevel (ClosedLevel 0) (unSingleLevel $ ignoreBlocking <$> b')         (as@(_:|_:_) , SingleClosed 0 :| []) ->-          sequence_ [ equalLevel' (unSingleLevel a') (ClosedLevel 0) | a' <- NonEmpty.toList as ]+          forM_ as $ \ a' -> equalLevel (unSingleLevel $ ignoreBlocking <$> a') (ClosedLevel 0)          -- meta == any-        (SinglePlus (Plus k (MetaLevel x as)) :| [] , bs)-          | any (isThisMeta x) bs -> postpone-        (as , SinglePlus (Plus k (MetaLevel x bs)) :| [])-          | any (isThisMeta x) as -> postpone-        (SinglePlus (Plus k (MetaLevel x as')) :| [] , SinglePlus (Plus l (MetaLevel y bs')) :| [])+        (SinglePlus (Plus k a) :| [] , SinglePlus (Plus l b) :| [])           -- there is only a potential choice when k == l-          | k == l -> if-              | y < x     -> meta x as' $ atomicLevel $ MetaLevel y bs'-              | otherwise -> meta y bs' $ atomicLevel $ MetaLevel x as'-        (SinglePlus (Plus k (MetaLevel x as')) :| [] , _)-          | Just b' <- subLevel k b -> meta x as' b'-        (_ , SinglePlus (Plus l (MetaLevel y bs')) :| [])-          | Just a' <- subLevel l a -> meta y bs' a'+          | MetaV x as' <- ignoreBlocking a+          , MetaV y bs' <- ignoreBlocking b+          , k == l -> do+              lvl <- levelType+              equalAtom (AsTermsOf lvl) (MetaV x as') (MetaV y bs')+        (SinglePlus (Plus k a) :| [] , _)+          | MetaV x as' <- ignoreBlocking a+          , Just b' <- subLevel k b -> meta x as' b'+        (_ , SinglePlus (Plus l b) :| [])+          | MetaV y bs' <- ignoreBlocking b+          , Just a' <- subLevel l a -> meta y bs' a'          -- a' ⊔ b == b         _ | Just a' <- levelMaxDiff a b@@ -1501,13 +1529,13 @@          -- neutral/closed == neutral/closed         (as , bs)-          | all isNeutralOrClosed (NonEmpty.toList as ++ NonEmpty.toList bs)+          | all isNeutralOrClosed (as <> bs)           -- Andreas, 2013-10-31: There could be metas in neutral levels (see Issue 930).           -- Should not we postpone there as well?  Yes!-          , not (any hasMeta (NonEmpty.toList as ++ NonEmpty.toList bs))+          , not (any hasMeta (as <> bs))           , length as == length bs -> do               reportSLn "tc.conv.level" 60 $ "equalLevel: all are neutral or closed"-              zipWithM_ ((===) `on` levelTm . unSingleLevel) (NonEmpty.toList as) (NonEmpty.toList bs)+              List1.zipWithM_ ((===) `on` levelTm . unSingleLevel . fmap ignoreBlocking) as bs          -- more cases?         _ | noMetas (Level a , Level b) -> notok@@ -1518,45 +1546,27 @@           lvl <- levelType           equalAtom (AsTermsOf lvl) a b -        ok       = return ()-        notok    = unlessM typeInType notOk-        notOk    = typeError $ UnequalLevel CmpEq a b-        postpone = do-          reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a <+> "==") 0 (pretty b)-          patternViolation--        -- perform assignment (MetaLevel x as) := b+        -- perform assignment (MetaV x as) := b         meta x as b = do           reportSLn "tc.meta.level" 30 $ "Assigning meta level"           reportSDoc "tc.meta.level" 50 $ "meta" <+> sep [prettyList $ map pretty as, pretty b]           lvl <- levelType           assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms -        -- Make sure to give a sensible error message-        wrap m = m `catchError` \case-            TypeError{} -> notok-            err         -> throwError err--        isNeutral (SinglePlus (Plus _ NeutralLevel{})) = True-        isNeutral _                                    = False--        isNeutralOrClosed (SingleClosed _)                     = True-        isNeutralOrClosed (SinglePlus (Plus _ NeutralLevel{})) = True-        isNeutralOrClosed _                                    = False+        isNeutral (SinglePlus (Plus _ NotBlocked{})) = True+        isNeutral _                                  = False -        hasMeta (SinglePlus a) = case a of-          Plus _ MetaLevel{}        -> True-          Plus _ (BlockedLevel _ v) -> isJust $ firstMeta v-          Plus _ (NeutralLevel _ v) -> isJust $ firstMeta v-          Plus _ (UnreducedLevel v) -> isJust $ firstMeta v-        hasMeta (SingleClosed _) = False+        isNeutralOrClosed (SingleClosed _)                   = True+        isNeutralOrClosed (SinglePlus (Plus _ NotBlocked{})) = True+        isNeutralOrClosed _                                  = False -        isThisMeta x (SinglePlus (Plus _ (MetaLevel y _))) = x == y-        isThisMeta _ _                                     = False+        hasMeta (SinglePlus (Plus _ Blocked{})) = True+        hasMeta (SinglePlus (Plus _ a))         = isJust $ firstMeta $ ignoreBlocking a+        hasMeta (SingleClosed _)                = False          removeSubsumed a b =-          let as = NonEmpty.toList $ levelMaxView a-              bs = NonEmpty.toList $ levelMaxView b+          let as = List1.toList $ levelMaxView a+              bs = List1.toList $ levelMaxView b               a' = unSingleLevels $ filter (not . (`isStrictlySubsumedBy` bs)) as               b' = unSingleLevels $ filter (not . (`isStrictlySubsumedBy` as)) bs           in (a',b')@@ -1588,6 +1598,7 @@          propEnabled <- isPropEnabled         typeInTypeEnabled <- typeInType+        omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions          case (s1, s2) of @@ -1608,18 +1619,21 @@             -- diagonal cases for rigid sorts             (Type a     , Type b     ) -> equalLevel a b `catchInequalLevel` no             (SizeUniv   , SizeUniv   ) -> yes+            (LockUniv   , LockUniv   ) -> yes             (Prop a     , Prop b     ) -> equalLevel a b `catchInequalLevel` no-            (Inf        , Inf        ) -> yes+            (Inf f m    , Inf f' n   ) ->+              if f == f' && (m == n || typeInTypeEnabled || omegaInOmegaEnabled) then yes else no+            (SSet a     , SSet b     ) -> equalLevel a b -            -- if --type-in-type is enabled, Setω is equal to any Set ℓ (see #3439)-            (Type{}     , Inf        )+            -- if --type-in-type is enabled, Setωᵢ is equal to any Set ℓ (see #3439)+            (Type{}     , Inf{}      )               | typeInTypeEnabled      -> yes-            (Inf        , Type{}     )+            (Inf{}      , Type{}     )               | typeInTypeEnabled      -> yes              -- equating @PiSort a b@ to another sort-            (s1 , PiSort a b) -> piSortEquals s1 a b-            (PiSort a b , s2) -> piSortEquals s2 a b+            (s1 , PiSort a b c) -> piSortEquals s1 a b c+            (PiSort a b c , s2) -> piSortEquals s2 a b c              -- equating @FunSort a b@ to another sort             (s1 , FunSort a b) -> funSortEquals s1 a b@@ -1648,7 +1662,7 @@       -- fall back to syntactic equality check, postpone if it fails       synEq :: Sort -> Sort -> m ()       synEq s1 s2 = do-        let postpone = addConstraint $ SortCmp CmpEq s1 s2+        let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) $ SortCmp CmpEq s1 s2         doSynEq <- optSyntacticEquality <$> pragmaOptions         if | doSynEq -> do                ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2@@ -1656,9 +1670,6 @@                   | otherwise -> postpone            | otherwise -> postpone -      set0 = mkType 0-      prop0 = mkProp 0-       -- Equate a sort @s1@ to @univSort s2@       -- Precondition: @s1@ and @univSort s2@ are already reduced.       univSortEquals :: Sort -> Sort -> m ()@@ -1674,8 +1685,8 @@           -- @Prop l2@ where @l1 == lsuc l2@.           Type l1 -> do             propEnabled <- isPropEnabled-               -- @s2@ is definitely not @Inf@ or @SizeUniv@-            if | Inf      <- s2 -> no+               -- @s2@ is definitely not @Inf n@ or @SizeUniv@+            if | Inf _ n  <- s2 -> no                | SizeUniv <- s2 -> no                -- If @Prop@ is not used, then @s2@ must be of the form                -- @Set l2@@@ -1689,11 +1700,12 @@                    equalSort (Type l2) s2                -- Otherwise we postpone                | otherwise -> synEq (Type l1) (UnivSort s2)-          -- @Setω@ is only a successor sort if --type-in-type or-          -- --omega-in-omega is enabled.-          Inf -> do+          -- @Setωᵢ@ is a successor sort if n > 0, or if+          -- --type-in-type or --omega-in-omega is enabled.+          Inf f n | n > 0 -> equalSort (Inf f $ n - 1) s2+          Inf f 0 -> do             infInInf <- (optOmegaInOmega <$> pragmaOptions) `or2M` typeInType-            if | infInInf  -> equalSort Inf s2+            if | infInInf  -> equalSort (Inf f 0) s2                | otherwise -> no           -- @Prop l@ and @SizeUniv@ are not successor sorts           Prop{}     -> no@@ -1702,29 +1714,31 @@           _          -> synEq s1 (UnivSort s2)  -      -- Equate a sort @s@ to @piSort a b@-      -- Precondition: @s@ and @piSort a b@ are already reduced.-      piSortEquals :: Sort -> Dom Type -> Abs Sort -> m ()-      piSortEquals s a NoAbs{} = __IMPOSSIBLE__-      piSortEquals s a bAbs@(Abs x b) = do+      -- Equate a sort @s@ to @piSort a s1 s2@+      -- Precondition: @s@ and @piSort a s1 s2@ are already reduced.+      piSortEquals :: Sort -> Dom Term -> Sort -> Abs Sort -> m ()+      piSortEquals s a s1 NoAbs{} = __IMPOSSIBLE__+      piSortEquals s a s1 s2Abs@(Abs x s2) = do+        let adom = El s1 <$> a         reportSDoc "tc.conv.sort" 35 $ vcat           [ "piSortEquals"-          , "  s =" <+> prettyTCM s-          , "  a =" <+> prettyTCM a-          , "  b =" <+> addContext (x,a) (prettyTCM b)+          , "  s  =" <+> prettyTCM s+          , "  a  =" <+> prettyTCM adom+          , "  s1 =" <+> prettyTCM s1+          , "  s2 =" <+> addContext (x,adom) (prettyTCM s2)           ]         propEnabled <- isPropEnabled-           -- If @b@ is dependent, then @piSort a b@ computes to-           -- @Setω@. Hence, if @s@ is definitely not @Setω@, then @b@+           -- If @s2@ is dependent, then @piSort a s1 s2@ computes to+           -- @Setωi@. Hence, if @s@ is small, then @s2@            -- cannot be dependent.-        if | definitelyNotInf s         -> do-               -- We force @b@ to be non-dependent by unifying it with+        if | Just (True,_) <- isSmallSort s -> do+               -- We force @s2@ to be non-dependent by unifying it with                -- a fresh meta that does not depend on @x : a@-               b' <- newSortMeta-               addContext (x,a) $ equalSort b (raise 1 b')-               funSortEquals s (getSort a) b'+               s2' <- newSortMeta+               addContext (x , adom) $ equalSort s2 (raise 1 s2')+               funSortEquals s s1 s2'            -- Otherwise: postpone-           | otherwise                  -> synEq (PiSort a bAbs) s+           | otherwise                  -> synEq (PiSort a s1 s2Abs) s        -- Equate a sort @s@ to @funSort s1 s2@       -- Precondition: @s@ and @funSort s1 s2@ are already reduced@@ -1739,13 +1753,14 @@         propEnabled <- isPropEnabled         sizedTypesEnabled <- sizedTypesOption         case s0 of-          -- If @Setω == funSort s1 s2@, then either @s1@ or @s2@ must-          -- be @Setω@.-          Inf | definitelyNotInf s1 && definitelyNotInf s2 -> do-                  typeError $ UnequalSorts s0 (FunSort s1 s2)-              | definitelyNotInf s1 -> equalSort Inf s2-              | definitelyNotInf s2 -> equalSort Inf s1-              | otherwise           -> synEq s0 (FunSort s1 s2)+          -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must+          -- be @Setωᵢ@.+          Inf f n | Just (True,_) <- isSmallSort s1, Just (True,_) <- isSmallSort s2 -> do+                    typeError $ UnequalSorts s0 (FunSort s1 s2)+                  | Just (True, IsFibrant) <- isSmallSort s1 -> equalSort (Inf f n) s2+                  | Just (True, IsFibrant) <- isSmallSort s2 -> equalSort (Inf f n) s1+                  -- TODO 2ltt: handle IsStrict cases.+                  | otherwise                   -> synEq s0 (FunSort s1 s2)           -- If @Set l == funSort s1 s2@, then @s2@ must be of the           -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@, or           -- @SizeUniv@.@@ -1789,19 +1804,7 @@       isBottomSort propEnabled (Prop (ClosedLevel 0)) = True       isBottomSort propEnabled (Type (ClosedLevel 0)) = not propEnabled       isBottomSort propEnabled _                      = False--      definitelyNotInf :: Sort -> Bool-      definitelyNotInf = \case-        Inf        -> False-        Type{}     -> True-        Prop{}     -> True-        SizeUniv   -> True-        PiSort{}   -> False-        FunSort{}  -> False-        UnivSort{} -> False-        MetaS{}    -> False-        DefS{}     -> False-        DummyS{}   -> False+      -- (NB: Defined but not currently used)        forceType :: Sort -> m Level       forceType (Type l) = return l@@ -1849,7 +1852,7 @@ --   xs <- mapM (mapM (\ (i,b) -> (,) i <$> intervalUnview (if b then IOne else IZero))) as --   return xs -forallFaceMaps :: MonadConversion m => Term -> (Map.Map Int Bool -> MetaId -> Term -> m a) -> (Substitution -> m a) -> m [a]+forallFaceMaps :: MonadConversion m => Term -> (Map.Map Int Bool -> Blocker -> Term -> m a) -> (Substitution -> m a) -> m [a] forallFaceMaps t kb k = do   reportSDoc "conv.forall" 20 $       fsep ["forallFaceMaps"@@ -1862,7 +1865,7 @@     return (\b -> if b then io else iz)   forM as $ \ (ms,ts) -> do    ifBlockeds ts (kb ms) $ \ _ _ -> do-    let xs = map (id -*- boolToI) $ Map.toAscList ms+    let xs = map (second boolToI) $ Map.toAscList ms     cxt <- getContext     reportSDoc "conv.forall" 20 $       fsep ["substContextN"@@ -1933,13 +1936,13 @@   it <- decomposeInterval' t   iu <- decomposeInterval' u   case () of-    _ | blockedOrMeta tb || blockedOrMeta ub -> do+    _ | isBlocked tb || isBlocked ub -> do       -- in case of metas we wouldn't be able to make progress by how we deal with de morgan laws.       -- (because the constraints generated by decomposition are sufficient but not necessary).       -- but we could still prune/solve some metas by comparing the terms as atoms.       -- also if blocked we won't find the terms conclusively unequal(?) so compareAtom       -- won't report type errors when we should accept.-      interval <- elInf $ primInterval+      interval <- primIntervalType       compareAtom CmpEq (AsTermsOf interval) t u     _ | otherwise -> do       x <- leqInterval it iu@@ -1949,11 +1952,10 @@         if final then typeError $ UnequalTerms cmp t u (AsTermsOf i)                  else do                    reportSDoc "tc.conv.interval" 15 $ "Giving up! }"-                   patternViolation+                   patternViolation (unblockOnAnyMetaIn (t, u))  where-   blockedOrMeta Blocked{} = True-   blockedOrMeta (NotBlocked _ (MetaV{})) = True-   blockedOrMeta _ = False+   isBlocked Blocked{}    = True+   isBlocked NotBlocked{} = False   type Conj = (Map.Map Int (Set.Set Bool),[Term])@@ -1974,24 +1976,23 @@ -- ' {r_i | i} ∪ {q_j | j} = {r_i | i} iff -- ' {q_j | j} ⊆ {r_i | i} leqConj :: MonadConversion m => Conj -> Conj -> m Bool-leqConj (rs,rst) (qs,qst) = do-  case toSet qs `Set.isSubsetOf` toSet rs of-    False -> return False-    True  -> do-      interval <- elInf $ fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval-+leqConj (rs, rst) (qs, qst) = do+  if toSet qs `Set.isSubsetOf` toSet rs+    then do+      interval <-+        elSSet $ fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval       -- we don't want to generate new constraints here because-      -- 1) in some situations the same constraint would get generated twice.-      -- 2) unless things are completely accepted we are going to+      -- 1. in some situations the same constraint would get generated twice.+      -- 2. unless things are completely accepted we are going to       --    throw patternViolation in compareInterval.       let eqT t u = tryConversion (compareAtom CmpEq (AsTermsOf interval) t u)--      let listSubset ts us = and <$> forM ts (\ t ->-                              or <$> forM us (\ u -> eqT t u)) -- TODO shortcut+      let listSubset ts us =+            and <$> forM ts (\t -> or <$> forM us (\u -> eqT t u)) -- TODO shortcut       listSubset qst rst+    else+      return False   where-    toSet m = Set.fromList [ (i,b) | (i,bs) <- Map.toList m, b <- Set.toList bs]-+    toSet m = Set.fromList [(i, b) | (i, bs) <- Map.toList m, b <- Set.toList bs]  -- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()@@ -2002,12 +2003,15 @@  compareTermOnFace' :: MonadConversion m => (Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m () compareTermOnFace' k cmp phi ty u v = do+  reportSDoc "tc.conv.face" 40 $+    text "compareTermOnFace:" <+> pretty phi <+> "|-" <+> pretty u <+> "==" <+> pretty v <+> ":" <+> pretty ty+   phi <- reduce phi   _ <- forallFaceMaps phi postponed          $ \ alpha -> k cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v)   return ()  where-  postponed ms i psi = do+  postponed ms blocker psi = do     phi <- runNamesT [] $ do              imin <- cl $ getPrimitiveTerm "primIMin"              ineg <- cl $ getPrimitiveTerm "primINeg"@@ -2015,7 +2019,7 @@              let phi = foldr (\ (i,b) r -> do i <- open (var i); pure imin <@> (if b then i else pure ineg <@> i) <@> r)                           psi (Map.toList ms) -- TODO Andrea: make a view?              phi-    addConstraint (ValueCmpOnFace cmp phi ty u v)+    addConstraint blocker (ValueCmpOnFace cmp phi ty u v)  --------------------------------------------------------------------------- -- * Definitions

src/full/Agda/TypeChecking/Conversion.hs-boot view

@@ -1,28 +1,22 @@  module Agda.TypeChecking.Conversion where +import Control.Monad.Except ( MonadError ) import qualified Control.Monad.Fail as Fail  import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (HasBuiltins) import Agda.TypeChecking.Warnings-import Agda.Utils.Except ( MonadError )  type MonadConversion m =-  ( MonadReduce m-  , MonadAddContext m+  ( PureTCM m   , MonadConstraint m   , MonadMetaSolver m   , MonadError TCErr m   , MonadWarning m-  , MonadDebug m   , MonadStatistics m   , MonadFresh ProblemId m   , MonadFresh Int m-  , HasBuiltins m-  , HasConstInfo m-  , HasOptions m   , Fail.MonadFail m   ) @@ -33,7 +27,6 @@ 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 ()-compareTel   :: MonadConversion m => Type -> Type -> Comparison -> Telescope -> Telescope -> m () compareSort  :: MonadConversion m => Comparison -> Sort -> Sort -> m () compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m () equalTerm    :: MonadConversion m => Type -> Term -> Term -> m ()

src/full/Agda/TypeChecking/Conversion/Pure.hs view

@@ -1,23 +1,26 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.TypeChecking.Conversion.Pure where +-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail)++import Control.Monad.Except import Control.Monad.State  import Data.String  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn)  import {-# SOURCE #-} Agda.TypeChecking.Conversion import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce (isBlocked) import Agda.TypeChecking.Warnings  import Agda.Utils.Either-import Agda.Utils.Except+import Agda.Utils.Maybe import Agda.Utils.Null  import Agda.Utils.Impossible@@ -30,32 +33,48 @@  newtype PureConversionT m a = PureConversionT   { unPureConversionT :: ExceptT TCErr (StateT FreshThings m) a }-  deriving (Functor, Applicative, Monad, MonadError TCErr, MonadState FreshThings)+  deriving (Functor, Applicative, Monad, MonadError TCErr, MonadState FreshThings, PureTCM)  pureEqualTerm-  :: (MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m)+  :: (PureTCM m, MonadBlock m)   => Type -> Term -> Term -> m Bool-pureEqualTerm a u v = locallyTC eCompareBlocked (const True) $-  isRight <$> runPureConversion (equalTerm a u v)+pureEqualTerm a u v =+  isJust <$> runPureConversion (equalTerm a u v) +pureEqualType+  :: (PureTCM m, MonadBlock m)+  => Type -> Type -> m Bool+pureEqualType a b =+  isJust <$> runPureConversion (equalType a b)+ pureCompareAs-  :: (MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m)+  :: (PureTCM m, MonadBlock m)   => Comparison -> CompareAs -> Term -> Term -> m Bool-pureCompareAs cmp a u v = locallyTC eCompareBlocked (const True) $-  isRight <$> runPureConversion (compareAs cmp a u v)+pureCompareAs cmp a u v =+  isJust <$> runPureConversion (compareAs cmp a u v)  runPureConversion-  :: (ReadTCState m, MonadDebug m, HasOptions m, MonadTCEnv m, Show a)-  => PureConversionT m a -> m (Either TCErr a)-runPureConversion (PureConversionT m) = do+  :: (MonadBlock m, PureTCM m, Show a)+  => PureConversionT m a -> m (Maybe a)+runPureConversion (PureConversionT m) = locallyTC eCompareBlocked (const True) $ do   i <- useR stFreshInt   pid <- useR stFreshProblemId   nid <- useR stFreshNameId   let frsh = FreshThings i pid nid   result <- fst <$> runStateT (runExceptT m) frsh   reportSLn "tc.conv.pure" 40 $ "runPureConversion result: " ++ show result-  return result+  case result of+    Left (PatternErr block)+     | block == neverUnblock -> return Nothing+     | otherwise             -> patternViolation block+    Left TypeError{}   -> return Nothing+    Left Exception{}   -> __IMPOSSIBLE__+    Left IOException{} -> __IMPOSSIBLE__+    Right x            -> return $ Just x +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)@@ -76,34 +95,42 @@   empty = return empty   null = __IMPOSSIBLE__ -instance (MonadTCEnv m, ReadTCState m, HasOptions m, MonadDebug m)-  => MonadConstraint (PureConversionT m) where-  addConstraint c = patternViolation-  addAwakeConstraint c = patternViolation+instance Monad m => MonadBlock (PureConversionT m) where+  patternViolation = throwError . PatternErr   catchPatternErr handle m = m `catchError` \case-    PatternErr{} -> handle+    PatternErr b -> handle b     err          -> throwError err-  solveConstraint c = patternViolation+++instance (PureTCM m, MonadBlock 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-  modifySleepingConstraints _ = patternViolation+  modifyAwakeConstraints _ = patternViolation alwaysUnblock  -- TODO: does this happen?+  modifySleepingConstraints _ = patternViolation alwaysUnblock  -- TODO: does this happen? -instance (MonadTCEnv m, MonadReduce m, MonadAddContext m, ReadTCState m, HasBuiltins m, HasConstInfo m, MonadDebug m)-  => MonadMetaSolver (PureConversionT m) where-  newMeta' _ _ _ _ _ _ = patternViolation-  assignV _ _ _ _ _ = patternViolation-  assignTerm' _ _ _ = patternViolation+instance (PureTCM m, MonadBlock 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+  updateMetaVar _ _ = patternViolation alwaysUnblock  -- TODO: does this happen?   speculateMetas fallback m = m >>= \case     KeepMetas     -> return ()     RollBackMetas -> fallback -instance (MonadTCEnv m, ReadTCState m) => MonadInteractionPoints (PureConversionT m) where-  freshInteractionId = patternViolation-  modifyInteractionPoints _ = patternViolation+instance (PureTCM m, MonadBlock m) => MonadInteractionPoints (PureConversionT m) where+  freshInteractionId = patternViolation alwaysUnblock  -- TODO: does this happen?+  modifyInteractionPoints _ = patternViolation alwaysUnblock  -- TODO: does this happen?  -- This is a bogus instance that promptly forgets all concrete names, -- but we don't really care@@ -112,10 +139,9 @@     concNames <- useR stConcreteNames     fst <$> runStateT m concNames -instance (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m)-  => MonadWarning (PureConversionT m) where+instance (PureTCM m, MonadBlock m) => MonadWarning (PureConversionT m) where   addWarning w = case classifyWarning (tcWarning w) of-    ErrorWarnings -> patternViolation+    ErrorWarnings -> patternViolation neverUnblock     AllWarnings   -> return ()  instance ReadTCState m => MonadStatistics (PureConversionT m) where

src/full/Agda/TypeChecking/Coverage.hs view

@@ -18,30 +18,28 @@ import Prelude hiding (null, (!!))  -- do not use partial functions like !!  import Control.Monad+import Control.Monad.Except import Control.Monad.Trans ( lift )  import Data.Foldable (for_) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet  import Agda.Syntax.Common import Agda.Syntax.Position-import Agda.Syntax.Internal+import Agda.Syntax.Internal hiding (DataOrRecord(..)) import Agda.Syntax.Internal.Pattern import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))  import Agda.TypeChecking.Names import Agda.TypeChecking.Primitive hiding (Nat)-import Agda.TypeChecking.Primitive.Cubical (trFillTel) import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin -import Agda.TypeChecking.Rules.LHS (checkSortOfSplitVar)+import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar) import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars) import Agda.TypeChecking.Rules.LHS.Unify import Agda.TypeChecking.Rules.Term (unquoteTactic)@@ -65,11 +63,6 @@ import Agda.Interaction.Options  import Agda.Utils.Either-import Agda.Utils.Except-  ( ExceptT-  , MonadError (throwError, catchError)-  , runExceptT-  ) import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe@@ -149,7 +142,7 @@   -> [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 " ++ show 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@@ -232,7 +225,8 @@                       , namedClausePats   = applySubst sub ps                       , clauseBody        = Nothing                       , clauseType        = Nothing-                      , clauseCatchall    = False+                      , clauseCatchall    = True       -- absurd clauses are safe as catch-all+                      , clauseExact       = Just False                       , clauseRecursive   = Just False                       , clauseUnreachable = Just False                       , clauseEllipsis    = NoEllipsis@@ -257,9 +251,15 @@    -- Andreas, 2017-08-28, issue #2723:   -- Mark clauses as reachable or unreachable in the signature.-  let (is0, cs1) = unzip $ for (zip [0..] cs) $ \ (i, cl) ->-        let unreachable = i `IntSet.notMember` used in-        (boolToMaybe unreachable i, cl { clauseUnreachable = Just unreachable  })+  -- Andreas, 2020-11-19, issue #5065+  -- Remember whether clauses are exact or not.+  let (is0, cs1) = unzip $ for (zip [0..] cs) $ \ (i, cl) -> let+          unreachable = i `IntSet.notMember` used+          exact       = i `IntSet.notMember` (IntSet.fromList noex)+        in (boolToMaybe unreachable i, cl+             { clauseUnreachable = Just unreachable+             , clauseExact       = Just exact+             })   -- is = indices of unreachable clauses   let is = catMaybes is0   reportSDoc "tc.cover.top" 10 $ vcat@@ -331,15 +331,18 @@   reportSLn "tc.cover.cover" 80 $ "raw target =\n" ++ show target   match cs ps >>= \case     Yes (i,mps) -> do-      exact <- allM (map snd mps) isTrivialPattern-      let cl0 = indexWithDefault __IMPOSSIBLE__ cs i-      let noExactClause = if exact || clauseCatchall (indexWithDefault __IMPOSSIBLE__ cs i)-                          then empty-                          else singleton 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+      reportSDoc "tc.cover.cover" 20 $ text "with mps = " <+> do addContext tel $ pretty mps+      exact <- allM mps $ isTrivialPattern . snd+      let cl0 = indexWithDefault __IMPOSSIBLE__ cs i       cl <- applyCl sc cl0 mps-      return $ CoverResult (SplittingDone (size tel)) (singleton i) [] [cl] noExactClause+      return $ CoverResult+        { coverSplitTree      = SplittingDone (size tel)+        , coverUsedClauses    = singleton i+        , coverMissingClauses = []+        , coverPatterns       = [cl]+        , coverNoExactClauses = IntSet.fromList [ i | not $ exact || clauseCatchall cl0 ]+        }      No        ->  do       reportSLn "tc.cover" 20 $ "pattern is not covered"@@ -376,12 +379,12 @@           splitError err   where     -- Andreas, 2019-08-07, issue #3966-    -- | When we get a SplitError, tighten the error Range to the clauses+    -- When we get a SplitError, tighten the error Range to the clauses     -- that are still candidates for covering the SplitClause.     splitError :: SplitError -> TCM a     splitError = withRangeOfCandidateClauses . typeError . SplitError -    -- | This repeats the matching, but since we are crashing anyway,+    -- This repeats the matching, but since we are crashing anyway,     -- the extra work just to compute a better Range does not matter.     withRangeOfCandidateClauses :: TCM a -> TCM a     withRangeOfCandidateClauses cont = do@@ -435,6 +438,7 @@                     , clauseBody      = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl                     , clauseType      = ty                     , clauseCatchall  = clauseCatchall cl+                    , clauseExact     = clauseExact cl                     , clauseRecursive = clauseRecursive cl                     , clauseUnreachable = clauseUnreachable cl                     , clauseEllipsis  = clauseEllipsis cl@@ -477,11 +481,11 @@                   _ -> False             caseMaybe (List.find (isComp . fst) scs) fallback $ \ (_, newSc) -> do             snoc cs <$> createMissingHCompClause f n x sc newSc-          results <- mapM (cover f cs) (map snd scs)+          results <- mapM ((cover f cs) . snd) scs           let trees = map coverSplitTree      results               useds = map coverUsedClauses    results               psss  = map coverMissingClauses results-              qsss  = map coverPatterns 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@@ -501,10 +505,10 @@      -- Try to split result     trySplitRes-      :: BlockedOnResult -- ^ Are we blocked on the result?-      -> Bool            -- ^ Is this the last thing we try?-      -> (SplitError -> TCM CoverResult) -- ^ Handler for 'SplitError'-      -> TCM CoverResult -- ^ Continuation+      :: BlockedOnResult                  -- Are we blocked on the result?+      -> Bool                             -- Is this the last thing we try?+      -> (SplitError -> TCM CoverResult)  -- Handler for 'SplitError'+      -> TCM CoverResult                  -- Continuation       -> TCM CoverResult     -- not blocked on result: try regular splits     trySplitRes NotBlockedOnResult finalSplit splitError cont@@ -519,8 +523,7 @@     -- ...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 $ \ sc ->-               cover f cs . snd =<< insertTrailingArgs sc+         caseMaybeM (splitResultPath f sc) fallback $ (cover f cs . snd) <=< insertTrailingArgs       where         fallback | finalSplit = __IMPOSSIBLE__ -- already ruled out by lhs checker?                  | otherwise  = cont@@ -620,6 +623,7 @@   io      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne   iz      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero   let+    cannotCreate :: forall m a. (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> Closure (Abs Type) -> m a     cannotCreate doc t = do       typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t   let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc@@ -656,7 +660,7 @@       (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel        -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)-      rhoS = liftS (size hdelta) $ raiseS 3+      {- rhoS = liftS (size hdelta) $ raiseS 3 -}       vs = iApplyVars (scPats old_sc)    -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]@@ -694,7 +698,6 @@           let             ineg j = pure tINeg <@> j             imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j             trFillTel' a b c d = do               m <- trFillTel <$> a <*> b <*> c <*> d               x <- lift $ runExceptT m@@ -702,13 +705,13 @@                 Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t                 Right args -> return args           comp <- do-            let forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))-                                              <@> (lam "i" $ \ i -> bA <@> (i `imax` r))+            let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))+                                              <@> lam "i" (\ i -> bA <@> (i `imax` r))                                               <@> r                                               <@> u             return $ \ la bA phi u u0 ->               pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                        <@> (lam "i" $ \ i -> ilam "o" $ \ o ->+                        <@> lam "i" (\ i -> ilam "o" $ \ o ->                                 forward la bA i (u <@> i <..> o))                         <@> forward la bA (pure iz) u0           let@@ -719,9 +722,9 @@              hfill la bA phi u u0 i = hcomp la bA                                                (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> (ilam "o" $ \ _ -> bA)-                                                     <@> (ilam "o" $ \ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> (ilam "o" $ \ _ -> u0)+                                               (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA)+                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)+                                                     <@> ilam "o" (\ _ -> u0)                                                    )                                                u0           -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)@@ -767,22 +770,22 @@                     v <- hfill lvl htype phi u u0 i                     hd <- old_t                     args <- delta_fill `bapp` i-                    lift $ piApplyM hd $ [Arg (domInfo hdom) v] ++ args+                    lift $ piApplyM hd $ Arg (domInfo hdom) v : args           ty_level <- do             t <- bind "i" ty             s <- reduce $ getSort (absBody t)             reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s             case s of-              Type l -> open =<< (lam "i" $ \ _ -> pure $ Level l)-              _      -> cannotCreate "Cannot compose with type family:" =<< (liftTCM $ buildClosure t)+              Type l -> open =<< lam "i" (\ _ -> pure $ Level l)+              _      -> cannotCreate "Cannot compose with type family:" =<< liftTCM (buildClosure t)            let             pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i)                                                <@> phi <@> psi-                                               <#> (ilam "o" $ \ _ -> unEl <$> ty i) <@> u0 <@> u1+                                               <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1           alpha <- do             vars <- mapM (open . applySubst hcompS . fst) alphab-            return $ foldr imax (pure iz) $ map (\ v -> v `imax` ineg v) vars+            return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars            -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]           b <- do@@ -794,12 +797,12 @@                                                             (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i))              let recurse []           i = __IMPOSSIBLE__                  recurse [(psi,u)]    i = u i-                 recurse ((psi,u):xs) i = pOr_ty i psi (foldr imax (pure iz) (map fst xs)) (u i) (recurse xs i)+                 recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i)              return $ recurse sides            ((,) <$> ty (pure io) <*>) $ do             comp ty_level-               (lam "i" $ \ i -> unEl <$> ty i)+               (lam "i" $ fmap unEl . ty)                            (phi `imax` alpha)                            (lam "i" $ \ i ->                                let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i)@@ -826,6 +829,7 @@                     , clauseBody      = Just $ rhs                     , clauseType      = Just $ defaultArg t                     , clauseCatchall  = False+                    , clauseExact       = Just True                     , clauseRecursive   = Nothing     -- TODO: can it be recursive?                     , clauseUnreachable = Just False  -- missing, thus, not unreachable                     , clauseEllipsis  = NoEllipsis@@ -864,6 +868,7 @@                   , clauseBody      = Just rhs                   , clauseType      = Just (argFromDom t)                   , clauseCatchall  = False+                  , clauseExact       = Just True                   , clauseRecursive   = Nothing     -- could be recursive                   , clauseUnreachable = Just False  -- missing, thus, not unreachable                   , clauseEllipsis  = NoEllipsis@@ -918,17 +923,19 @@           | otherwise -> do               let (ps, is) = splitAt np args               return (IsData, d, ps, is, cs, not $ null (dataPathCons def))-        Record{recPars = np, recConHead = con, recInduction = i}+        Record{recPars = np, recConHead = con, recInduction = i, recEtaEquality'}           | i == Just CoInductive && ind /= CoInductive ->               throw CoinductiveDatatype           | otherwise ->-              return (IsRecord, d, args, [], [conName con], False)+              return (IsRecord i recEtaEquality', d, args, [], [conName con], False)         _ -> throw NotADatatype     _ -> throw NotADatatype  -- | Update the target type of the split clause after a case split.-fixTargetType :: SplitClause -> Dom Type -> TCM SplitClause-fixTargetType sc@SClause{ scTel = sctel, scSubst = sigma } target = do+fixTargetType+  :: Quantity  -- ^ The quantity of the thing that is split.+  -> SplitTag -> SplitClause -> Dom Type -> TCM SplitClause+fixTargetType q tag sc@SClause{ scTel = sctel, scSubst = sigma } target = do     reportSDoc "tc.cover.target" 20 $ sep       [ "split clause telescope: " <+> prettyTCM sctel       ]@@ -939,14 +946,34 @@       [ "target type before substitution:" <+> pretty target       , "             after substitution:" <+> pretty (applySplitPSubst sigma target)       ]-    return $ sc { scTarget = Just $ applySplitPSubst sigma target } +    -- We update the target quantity to 0 for erased constructors, but+    -- not if the match is made in an erased position.+    updQuant <- do+      let erased = case q of+            Quantity0{} -> True+            Quantity1{} -> __IMPOSSIBLE__+            Quantityω{} -> False+      if erased then return id else case tag of+        SplitCon c -> do+          q <- getQuantity <$> getConstInfo c+          case q of+            Quantity0{} -> return $ mapQuantity (composeQuantity q)+            Quantity1{} -> return id+            Quantityω{} -> return id+        SplitLit{} -> return id+        SplitCatchall{} -> return id +    return $ sc { scTarget = Just $ updQuant $ applySplitPSubst sigma target }++ -- | Add more patterns to split clause if the target type is a function type. --   Returns the domains of the function type (if any). insertTrailingArgs :: SplitClause -> TCM (Telescope, SplitClause)-insertTrailingArgs sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scCheckpoints = cps, scTarget = target } =-  caseMaybe target (return (empty,sc)) $ \ a -> do+insertTrailingArgs sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scCheckpoints = cps, scTarget = target } = do+  let fallback = return (empty, sc)+  caseMaybe target fallback $ \ a -> do+    if isJust (domTactic a) then fallback else do     (TelV tel b) <- telViewUpTo (-1) $ unDom a     reportSDoc "tc.cover.target" 15 $ sep       [ "target type telescope: " <+> do@@ -1029,16 +1056,7 @@       -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ       let (rho1,rho2) = splitS (size gamma) $ toSplitPSubst rho0 -      -- Andreas, 2015-05-01  I guess it is fine to use no @conPType@-      -- as the result of splitting is never used further down the pipeline.-      -- After splitting, Agda reloads the file.-      -- Andreas, 2017-09-03, issue #2729: remember that pattern was generated by case split.-      let-          -- cpi  = noConPatternInfo{ conPRecord = Just PatOSplit }-          -- conp = ConP con cpi $ applySubst rho2 $-          --          map (mapArgInfo hiddenInserted) $ tele2NamedArgs gamma0 gamma-          -- -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names-          defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $+      let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $                    map (fmap unnamed) [setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dlvl                                       ,setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dterm]                    ++ applySubst rho2 (teleNamedArgs gamma) -- rho0?@@ -1111,12 +1129,14 @@         Just cixs = allApplyElims es     return (gamma0, cixs, boundary) +  let (_, Dom{domInfo = info} : _) = splitAt (size tel - hix - 1) (telToList tel)+   -- 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  = 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@@ -1135,24 +1155,33 @@   -- TODO: should we propagate the modality in general?   -- See also LHS checking.   dtype <- do-         let (_, Dom{domInfo = info} : _) = splitAt (size tel - hix - 1) (telToList tel)          let updCoh = composeCohesion (getCohesion info)          TelV dtel dt <- telView dtype          return $ abstract (mapCohesion updCoh <$> dtel) dt -  r <- unifyIndices+  withKIfStrict <- addContext delta1 $ reduce (getSort dtype) >>= \case+    SSet{} -> return $ locallyTC eSplitOnStrict $ const True+    _      -> return id++  r <- withKIfStrict $ unifyIndices          delta1Gamma          flex          (raise (size gamma) dtype)          conIxs          givenIxs +  let stuck b errs = do+        debugCantSplit+        throwError $ UnificationStuck b (conName con) (delta1 `abstract` gamma) conIxs givenIxs errs++   case r of     NoUnify {} -> debugNoUnify $> Nothing -    DontKnow errs -> do-      debugCantSplit-      throwError $ UnificationStuck (conName con) (delta1 `abstract` gamma) conIxs givenIxs errs+    UnifyBlocked block -> stuck (Just block) []++    UnifyStuck errs -> stuck Nothing errs+     Unifies (delta1',rho0,_) -> do       debugSubst "rho0" rho0 @@ -1279,7 +1308,9 @@  splitLast :: Induction -> Telescope -> [NamedArg DeBruijnPattern] -> TCM (Either SplitError Covering) splitLast ind tel ps = split ind NoAllowPartialCover sc (BlockingVar 0 [] [] True False)-  where sc = SClause tel (toSplitPatterns ps) empty empty Nothing+  where sc = SClause tel (toSplitPatterns ps) empty empty target+        -- TODO 2ltt: allows (Empty_fib -> Empty_strict) which is not conservative+        target = (Just $ defaultDom $ El (Prop (Max 0 [])) $ Dummy "splitLastTarget" [])  -- | @split ind splitClause x = return res@ --   splits @splitClause@ at pattern var @x@ (de Bruijn index).@@ -1416,7 +1447,8 @@         else computeNeighborhoods    ns <- case target of-    Just a  -> forM ns $ \ (con, sc) -> lift $ (con,) <$> fixTargetType sc a+    Just a  -> forM ns $ \ (con, sc) -> lift $ (con,) <$>+                 fixTargetType (getQuantity t) con sc a     Nothing -> return ns    ns <- case inserttrailing of@@ -1424,12 +1456,6 @@     DoInsertTrailing   -> lift $ forM ns $ \(con,sc) ->       (con,) . snd <$> insertTrailingArgs sc -  -- Andreas, 2018-10-27, issue #3324; use isPropM.-  -- Need to reduce sort to decide on Prop.-  -- Cannot split if domain is a Prop but target is relevant.-  propArrowRel <- isPropM t `and2M`-    maybe (return True) (not <.> isPropM) target-   mHCompName <- getPrimitiveName' builtinHComp   withoutK   <- collapseDefault . optWithoutK <$> pragmaOptions @@ -1438,6 +1464,7 @@   let erasedError causedByWithoutK =         throwError . ErasedDatatype causedByWithoutK =<<           do liftTCM $ inContextOfT $ buildClosure (unDom t)+   case ns of     []  -> do       let absurdp = VarP (PatternInfo PatOAbsurd []) $ SplitPatVar underscore 0 []@@ -1451,13 +1478,8 @@                , scTarget             = Nothing                } -    -- Jesper, 2018-05-24: If the datatype is in Prop we can-    -- only do empty splits, unless the target is in Prop too.-    (_ : _) | dr == IsData && propArrowRel ->-      throwError . IrrelevantDatatype =<< do liftTCM $ inContextOfT $ buildClosure (unDom t)-     -- Andreas, 2018-10-17: If more than one constructor matches, we cannot erase.-    (_ : _ : _) | not erased && not (usableQuantity t) ->+    _ : _ : _ | not erased && not (usableQuantity t) ->       erasedError False      -- If exactly one constructor matches and the K rule is turned@@ -1477,9 +1499,9 @@       let inferred_tags = maybe Set.empty (Set.singleton . SplitCon) mHCompName       let all_tags = Set.fromList ptags `Set.union` inferred_tags -      when (allowPartialCover == NoAllowPartialCover && overlap == False) $+      when (allowPartialCover == NoAllowPartialCover && not overlap) $         for_ ns $ \(tag, sc) -> do-          when (not $ tag `Set.member` all_tags) $ do+          unless (tag `Set.member` all_tags) $ do             isImpossibleClause <- liftTCM $ isEmptyTel $ scTel sc             unless isImpossibleClause $ do               liftTCM $ reportSDoc "tc.cover" 10 $ vcat@@ -1488,13 +1510,13 @@                 ]               throwError (GenericSplitError "precomputed set of constructors does not cover all cases") -      liftTCM $ checkSortOfSplitVar dr (unDom t) target+      liftTCM $ checkSortOfSplitVar dr (unDom t) delta2 target       return $ Right $ Covering (lookupPatternVar sc x) ns    where     inContextOfT, inContextOfDelta2 :: (MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) => tcm a -> tcm a-    inContextOfT      = addContext tel . escapeContext __IMPOSSIBLE__ (x + 1)-    inContextOfDelta2 = addContext tel . escapeContext __IMPOSSIBLE__ x+    inContextOfT      = addContext tel . escapeContext impossible (x + 1)+    inContextOfDelta2 = addContext tel . escapeContext impossible x      -- Debug printing     debugInit tel x ps cps = liftTCM $ inTopContext $ do@@ -1559,7 +1581,7 @@   reportSDoc "tc.cover.split" 10 $ vcat     [ "splitting result:"     , nest 2 $ "f      =" <+> prettyTCM f-    , nest 2 $ "target =" <+> (addContext tel $ maybe empty prettyTCM target)+    , nest 2 $ "target =" <+> addContext tel (maybe empty prettyTCM target)     ]   -- if we want to split projections, but have no target type, we give up   let failure = return . Left@@ -1569,7 +1591,7 @@       Just (_r, vs, Record{ recFields = fs }) -> do         reportSDoc "tc.cover" 20 $ sep           [ text $ "we are of record type _r = " ++ prettyShow _r-          , text   "applied to parameters vs =" <+> (addContext tel $ prettyTCM vs)+          , text   "applied to parameters vs =" <+> addContext tel (prettyTCM vs)           , text $ "and have fields       fs = " ++ prettyShow fs           ]         -- Andreas, 2018-06-09, issue #2170, we always have irrelevant projections@@ -1599,7 +1621,7 @@             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)

src/full/Agda/TypeChecking/Coverage/Match.hs view

@@ -1,3 +1,4 @@+ {-| Given      1. the function clauses @cs@@@ -28,14 +29,12 @@ import Data.Maybe (mapMaybe, fromMaybe) import Data.Semigroup ( Semigroup, (<>)) -import Agda.Syntax.Abstract (IsProjP(..)) import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Literal import Agda.Syntax.Position  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty ( PrettyTCM(..) ) import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce@@ -101,14 +100,14 @@ -- -- If successful, return the index of the covering clause. ---match :: (MonadReduce m , HasConstInfo m , HasBuiltins m)+match :: PureTCM m       => [Clause]                           -- ^ Search for clause that covers the patterns.       -> [NamedArg SplitPattern]            -- ^ Patterns of the current 'SplitClause'.       -> m (Match (Nat, SplitInstantiation)) match cs ps = foldr choice (return No) $ zipWith matchIt [0..] cs   where-    matchIt :: (MonadReduce m , HasConstInfo m , HasBuiltins m)-            => Nat     -- ^ Clause number.+    matchIt :: PureTCM m+            => Nat  -- Clause number.             -> Clause             -> m (Match (Nat, SplitInstantiation))     matchIt i c = fmap (i,) <$> matchClause ps c@@ -125,9 +124,9 @@  instance Pretty SplitPatVar where   prettyPrec _ x =-    (text $ patVarNameToString (splitPatVarName x)) <>-    (text $ "@" ++ show (splitPatVarIndex x)) <>-    (ifNull (splitExcludedLits x) empty $ \lits ->+    text (patVarNameToString (splitPatVarName x)) <>+    text ("@" ++ show (splitPatVarIndex x)) <>+    ifNull (splitExcludedLits x) empty (\lits ->       "\\{" <> prettyList_ lits <> "}")  instance PrettyTCM SplitPatVar where@@ -159,25 +158,27 @@ fromSplitPSubst :: SplitPSubstitution -> PatternSubstitution fromSplitPSubst = (fmap . fmap) fromSplitVar -applySplitPSubst :: (Subst Term a) => SplitPSubstitution -> a -> a+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 SplitPattern where-  applySubst IdS p = p-  applySubst rho p = case p of-    VarP i x     ->+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-    LitP{}       -> p-    ProjP{}      -> p-    IApplyP i l r 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) $@@ -206,7 +207,7 @@  -- | A pattern that matches anything (modulo eta). isTrivialPattern :: (HasConstInfo m) => Pattern' a -> m Bool-isTrivialPattern p = case p of+isTrivialPattern = \case   VarP{}      -> return True   DotP{}      -> return True   ConP c i ps -> andM $ ((conPLazy i ||) <$> isEtaCon (conName c))@@ -306,7 +307,7 @@ -- | @matchClause qs i c@ checks whether clause @c@ --   covers a split clause with patterns @qs@. matchClause-  :: (MonadReduce m , HasConstInfo m , HasBuiltins m)+  :: PureTCM m   => [NamedArg SplitPattern]      -- ^ Split clause patterns @qs@.   -> Clause@@ -333,7 +334,7 @@ --   in @mconcat []@ which is @Yes []@.  matchPats-  :: (MonadReduce m , HasConstInfo m , HasBuiltins m, DeBruijn a)+  :: (PureTCM m, DeBruijn a)   => [NamedArg (Pattern' a)]      -- ^ Clause pattern vector @ps@ (to cover split clause pattern vector).   -> [NamedArg SplitPattern]@@ -396,7 +397,7 @@ --      a cover if @q@ was split on variable @x@.  matchPat-  :: (MonadReduce m , HasConstInfo m , HasBuiltins m, DeBruijn a)+  :: (PureTCM m, DeBruijn a)   => Pattern' a      -- ^ Clause pattern @p@ (to cover split clause pattern).   -> SplitPattern@@ -466,27 +467,29 @@   v     -> return $ dotP v unDotP p = return p -isLitP :: (MonadReduce m, HasBuiltins m) => Pattern' a -> m (Maybe Literal)+isLitP :: PureTCM m => Pattern' a -> m (Maybe Literal) isLitP (LitP _ l) = return $ Just l isLitP (DotP _ u) = reduce u >>= \case   Lit l -> return $ Just l-  _     -> return $ Nothing+  _ -> return $ Nothing isLitP (ConP c ci []) = do   Con zero _ [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero-  if | c == zero -> return $ Just $ LitNat (getRange c) 0-     | otherwise -> return Nothing+  if c == zero+    then return $ Just $ LitNat 0+    else return Nothing isLitP (ConP c ci [a]) | visible a && isRelevant a = do   Con suc _ [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc-  if | c == suc  -> fmap inc <$> isLitP (namedArg a)-     | otherwise -> return Nothing+  if c == suc+    then fmap inc <$> isLitP (namedArg a)+    else return Nothing   where     inc :: Literal -> Literal-    inc (LitNat r n) = LitNat (fuseRange c r) $ n + 1+    inc (LitNat n) = LitNat $ n + 1     inc _ = __IMPOSSIBLE__ isLitP _ = return Nothing  unLitP :: HasBuiltins m => Pattern' a -> m (Pattern' a)-unLitP (LitP info l@(LitNat _ n)) | n >= 0 = do+unLitP (LitP info l@(LitNat n)) | n >= 0 = do   Con c ci es <- constructorForm' (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero)                                   (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc)                                   (Lit l)

src/full/Agda/TypeChecking/Coverage/SplitTree.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable         #-}  {-| Split tree for transforming pattern clauses into case trees. @@ -13,9 +12,13 @@ -} module Agda.TypeChecking.Coverage.SplitTree where +import Control.DeepSeq+ import Data.Tree import Data.Data (Data) +import GHC.Generics (Generic)+ import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Concrete.Pretty () --instance only@@ -43,10 +46,10 @@     , splitLazy  :: LazySplit     , splitTrees :: SplitTrees' a -- ^ Sub split trees.     }-  deriving (Data, Show)+  deriving (Data, Show, Generic)  data LazySplit = LazySplit | StrictSplit-  deriving (Data, Show, Eq, Ord)+  deriving (Data, Show, Eq, Ord, Generic)  -- | Split tree branching.  A finite map from constructor names to splittrees --   A list representation seems appropriate, since we are expecting not@@ -61,7 +64,7 @@   = SplitCon QName   | SplitLit Literal   | SplitCatchall-  deriving (Show, Eq, Ord, Data)+  deriving (Show, Eq, Ord, Data, Generic)  instance Pretty SplitTag where   pretty (SplitCon c) = pretty c@@ -88,7 +91,7 @@  -- | Convert a split tree into a 'Data.Tree' (for printing). toTree :: SplitTree' a -> Tree (SplitTreeLabel a)-toTree t = case t of+toTree = \case   SplittingDone n -> Node (SplitTreeLabel Nothing Nothing StrictSplit (Just n)) []   SplitAt n lz ts    -> Node (SplitTreeLabel Nothing (Just n) lz Nothing) $ toTrees ts @@ -111,3 +114,7 @@   killRange = \case     SplittingDone n -> SplittingDone n     SplitAt i lz ts -> killRange1 (SplitAt i lz) ts++instance NFData a => NFData (SplitTree' a)+instance NFData LazySplit+instance NFData SplitTag

src/full/Agda/TypeChecking/Datatypes.hs view

@@ -4,13 +4,11 @@ import Control.Monad.Except  import Data.Maybe (fromMaybe)-import qualified Data.List as List  import Agda.Syntax.Common import Agda.Syntax.Internal  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (constructorForm) import Agda.TypeChecking.Telescope import Agda.TypeChecking.Substitute import Agda.TypeChecking.Pretty@@ -58,7 +56,7 @@  -- | Is the datatype of this constructor a Higher Inductive Type? --   Precondition: The argument must refer to a constructor of a datatype or record.-consOfHIT :: QName -> TCM Bool+consOfHIT :: HasConstInfo m => QName -> m Bool consOfHIT c = do   d <- getConstructorData c   def <- theDef <$> getConstInfo d@@ -75,7 +73,7 @@ --   @Nothing@ if @t@ is not a data/record type or does not have --   a constructor @c@. getConType-  :: (MonadReduce m, MonadAddContext m, HasConstInfo m, MonadDebug m)+  :: PureTCM m   => ConHead  -- ^ Constructor.   -> Type     -- ^ Ending in data/record type.   -> m (Maybe ((QName, Type, Args), Type))@@ -100,11 +98,11 @@   -- (applied to at least the parameters).   -- Note: @t@ will have some unbound deBruijn indices if view outside of @tel@.   reportSLn "tc.getConType" 35 $ "  target type: " ++ prettyShow t-  applySubst (strengthenS __IMPOSSIBLE__ (size tel)) <$> do+  applySubst (strengthenS impossible (size tel)) <$> do     addContext tel $ getFullyAppliedConType c t   -- Andreas, 2017-08-18, issue #2703:   -- The original code-  --    getFullyAppliedConType c $ applySubst (strengthenS __IMPOSSIBLE__ (size tel)) t+  --    getFullyAppliedConType c $ applySubst (strengthenS impossible (size tel)) t   -- crashes because substitution into @Def@s is slightly too strict   -- (see @defApp@ and @canProject@).   -- Strengthening the parameters after the call to @getFullyAppliedConType@@@ -120,7 +118,7 @@ -- --   Precondition: @t@ is reduced. getFullyAppliedConType-  :: (HasConstInfo m, MonadReduce m, MonadDebug m)+  :: PureTCM m   => ConHead  -- ^ Constructor.   -> Type     -- ^ Reduced type of the fully applied constructor.   -> m (Maybe ((QName, Type, Args), Type))@@ -132,7 +130,7 @@        --     @pars@ are the reconstructed parameters,        --     @ct@   is the type of the constructor instantiated to the parameters. getFullyAppliedConType c t = do-  reportSLn "tc.getConType" 35 $ List.intercalate " " $+  reportSLn "tc.getConType" 35 $ unwords $     [ "getFullyAppliedConType", prettyShow c, prettyShow t ]   c <- fromRight __IMPOSSIBLE__ <$> do getConHead $ conName c   case unEl t of@@ -140,7 +138,7 @@     -- then the non-parameter arguments of @es@ might contain __IMPOSSIBLE__     -- coming from strengthening.  (Thus, printing them is not safe.)     Def d es -> do-      reportSLn "tc.getConType" 35 $ List.intercalate " " $+      reportSLn "tc.getConType" 35 $ unwords $         [ "getFullyAppliedConType: case Def", prettyShow d, prettyShow es ]       def <- getConstInfo d       let cont n = do@@ -155,8 +153,10 @@     _ -> return Nothing  data ConstructorInfo-  = DataCon Nat                  -- ^ Arity.-  | RecordCon HasEta [Dom QName] -- ^ List of field names.+  = DataCon Nat+      -- ^ Arity.+  | RecordCon PatternOrCopattern HasEta [Dom QName]+      -- ^ List of field names.  -- | Return the number of non-parameter arguments to a data constructor, --   or the field names of a record constructor.@@ -169,7 +169,7 @@     Constructor{ conData = d, conArity = n } -> do       (theDef <$> getConstInfo d) >>= \case         r@Record{ recFields = fs } ->-           return $ RecordCon (recEtaEquality r) fs+           return $ RecordCon (recPatternMatching r) (recEtaEquality r) fs         Datatype{} ->            return $ DataCon n         _ -> __IMPOSSIBLE__@@ -191,20 +191,18 @@ -- | Check if a name refers to a datatype or a record. isDataOrRecordType :: QName -> TCM (Maybe DataOrRecord) isDataOrRecordType d = do-  def <- getConstInfo d-  case theDef def of+  (theDef <$> getConstInfo d) >>= \case+    Record{ recPatternMatching } -> return $ Just $ IsRecord recPatternMatching     Datatype{} -> return $ Just IsData-    Record{}   -> return $ Just IsRecord     _          -> return $ Nothing  -- | Precodition: 'Term' is 'reduce'd. isDataOrRecord :: Term -> TCM (Maybe QName)-isDataOrRecord v = do-  case v of+isDataOrRecord = \case     Def d _ -> fmap (const d) <$> isDataOrRecordType d     _       -> return Nothing -getNumberOfParameters :: QName -> TCM (Maybe Nat)+getNumberOfParameters :: HasConstInfo m => QName -> m (Maybe Nat) getNumberOfParameters d = do   def <- getConstInfo d   case theDef def of@@ -213,6 +211,12 @@     Constructor{ conPars = n } -> return $ Just n     _                          -> return Nothing +getNotErasedConstructors :: QName -> TCM [QName]+getNotErasedConstructors d = do+  cs <- getConstructors d+  flip filterM cs $ \ c -> do+    usableModality <$> getConstInfo c+ -- | Precondition: Name is a data or record type. getConstructors :: QName -> TCM [QName] getConstructors d = fromMaybe __IMPOSSIBLE__ <$>@@ -228,68 +232,3 @@     Datatype{dataCons = cs} -> Just cs     Record{recConHead = h}  -> Just [conName h]     _                       -> Nothing---- | Precondition: Name is a data or record type.-getConHeads :: QName -> TCM [ConHead]-getConHeads d = fromMaybe __IMPOSSIBLE__ <$>-  getConHeads' d---- | 'Nothing' if not data or record type name.-getConHeads' :: QName -> TCM (Maybe [ConHead])-getConHeads' d = theDef <$> getConstInfo d >>= \case-  Record{recConHead = h}  -> return $ Just [h]-  Datatype{dataCons = cs} -> Just <$> mapM makeConHead cs-  _                       -> return $ Nothing---- | Fills in the fields.-makeConHead :: QName -> TCM ConHead-makeConHead c = do-  def <- getConstInfo c-  case theDef def of-    Constructor{conPars = n, conProj = Just fs} -> do-      TelV tel _ <- telView (defType def)-      let ai = map getArgInfo $ drop n $ telToList tel-      return $ ConHead c Inductive $ zipWith Arg ai fs-    Constructor{conProj = Nothing} -> return $ ConHead c Inductive []-    _ -> __IMPOSSIBLE__--{- UNUSED-data DatatypeInfo = DataInfo-  { datatypeName   :: QName-  , datatypeParTel :: Telescope-  , datatypePars   :: Args-  , datatypeIxTel  :: Telescope-  , datatypeIxs    :: Args-  }---- | Get the name and parameters from a type if it's a datatype or record type---   with a named constructor.-getDatatypeInfo :: Type -> TCM (Maybe DatatypeInfo)-getDatatypeInfo t = do-  t <- reduce t-  case unEl t of-    Def d args -> do-      n          <- getDefFreeVars d-      args       <- return $ genericDrop n args-      def        <- instantiateDef =<< getConstInfo d-      TelV tel _ <- telView (defType def)-      let npars  = case theDef def of-            Datatype{dataPars = np} -> Just np-            Record{recPars = np, recNamedCon = True}-              | genericLength args == np -> Just np-              | otherwise                -> __IMPOSSIBLE__-            _                            -> Nothing-      return $ do-        np <- npars-        let (pt, it) = genericSplitAt np $ telToList tel-            parTel   = telFromList pt-            ixTel    = telFromList it-            (ps, is) = genericSplitAt np args-        return $ DataInfo { datatypeName = d-                          , datatypeParTel = parTel-                          , datatypePars   = ps-                          , datatypeIxTel  = ixTel-                          , datatypeIxs    = is-                          }-    _ -> return Nothing--}

src/full/Agda/TypeChecking/DeadCode.hs view

@@ -1,9 +1,9 @@ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where +import Data.Monoid (All(..)) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Traversable (traverse) import qualified Data.HashMap.Strict as HMap  import qualified Agda.Syntax.Abstract as A@@ -25,14 +25,14 @@ eliminateDeadCode :: DisplayForms -> Signature -> TCM (DisplayForms, Signature) eliminateDeadCode disp sig = Bench.billTo [Bench.DeadCode] $ do   patsyn <- getPatternSyns-  public <- Set.map anameName . publicNames <$> getScope+  public <- Set.mapMonotonic anameName . publicNames <$> getScope   defs <- traverse instantiateFull $ sig ^. sigDefinitions   -- #2921: Eliminating definitions with attached COMPILE pragmas results in   -- the pragmas not being checked. Simple solution: don't eliminate these.   let hasCompilePragma = Set.fromList . HMap.keys . HMap.filter (not . Map.null . defCompiledRep) $ defs   let r     = reachableFrom (Set.union public hasCompilePragma) patsyn defs       dead  = Set.fromList (HMap.keys defs) `Set.difference` r-      valid = Set.null . Set.intersection dead . namesIn+      valid = getAll . namesIn' (All . (`Set.notMember` dead))  -- no used name is dead       defs' = HMap.map ( \ d -> d { defDisplay = filter valid (defDisplay d) } )             $ HMap.filterWithKey (\ x _ -> Set.member x r) defs       disp' = HMap.filter (not . null) $ HMap.map (filter valid) disp@@ -45,8 +45,7 @@     follow visited [] = visited     follow visited (x : xs) = follow (Set.union visited new) (Set.toList new ++ xs)       where-        new = Set.filter (not . (`Set.member` visited)) $-                case HMap.lookup x defs of+        new = names `Set.difference` visited+        names = case HMap.lookup x defs of                   Nothing -> namesIn (PSyn <$> Map.lookup x psyns)                   Just d  -> namesIn d-

src/full/Agda/TypeChecking/DisplayForm.hs view

@@ -2,14 +2,16 @@  -- | Tools for 'DisplayTerm' and 'DisplayForm'. -module Agda.TypeChecking.DisplayForm where+module Agda.TypeChecking.DisplayForm (displayForm) where -import Prelude hiding (all) import Control.Monad import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe-import Data.Foldable (all)++import Data.Monoid (All(..))+import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -17,7 +19,6 @@ import Agda.Syntax.Scope.Base (inverseScopeLookupName)  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (HasBuiltins(..)) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Level import Agda.TypeChecking.Reduce (instantiate)@@ -43,6 +44,17 @@ displayFormArities :: (HasConstInfo m, ReadTCState m) => QName -> m [Int] displayFormArities q = map (length . dfPats . dget) <$> getDisplayForms q +-- | Lift a local display form to an outer context. The substitution goes from the parent context to+--   the context of the local display form (see Issue 958). Current only handles pure extensions of+--   the parent context.+liftLocalDisplayForm :: Substitution -> DisplayForm -> Maybe DisplayForm+liftLocalDisplayForm IdS df = Just df+liftLocalDisplayForm (Wk n IdS) (Display m lhs rhs) =+  -- We lift a display form by turning matches on free variables into pattern variables, which can+  -- be done by simply adding to the dfPatternVars field.+  Just $ Display (n + m) lhs rhs+liftLocalDisplayForm _ _ = Nothing+ type MonadDisplayForm m =   ( MonadReduce m   , ReadTCState m@@ -64,16 +76,16 @@     return Nothing   else do     -- Display debug info about the @Open@s.-    verboseS "tc.display.top" 100 $ unlessDebugPrinting $ do+    unlessDebugPrinting $ reportSDoc "tc.display.top" 100 $ do       cps <- viewTC eCheckpoints       cxt <- getContextTelescope-      reportSDoc "tc.display.top" 100 $ return $ vcat+      return $ vcat         [ "displayForm for" <+> pretty q         , nest 2 $ "cxt =" <+> pretty cxt         , nest 2 $ "cps =" <+> vcat (map pretty (Map.toList cps))-        , nest 2 $ "dfs =" <+> vcat (map pshow odfs) ]+        , nest 2 $ "dfs =" <+> vcat (map pretty odfs) ]     -- Use only the display forms that can be opened in the current context.-    dfs   <- catMaybes <$> mapM tryGetOpen odfs+    dfs   <- catMaybes <$> mapM (tryGetOpen liftLocalDisplayForm) odfs     scope <- getScope     -- Keep the display forms that match the application @q es@.     ms <- do@@ -81,12 +93,12 @@       return [ m | Just (d, m) <- ms, wellScoped scope d ]     -- Not safe when printing non-terminating terms.     -- (nfdfs, us) <- normalise (dfs, es)-    unlessDebugPrinting $ reportS "tc.display.top" 100-      [ "name        : " ++ prettyShow q-      , "displayForms: " ++ show dfs-      , "arguments   : " ++ show es-      , "matches     : " ++ show ms-      , "result      : " ++ show (listToMaybe ms)+    unlessDebugPrinting $ reportSDoc "tc.display.top" 100 $ return $ vcat+      [ "name        :" <+> pretty q+      , "displayForms:" <+> pretty dfs+      , "arguments   :" <+> pretty es+      , "matches     :" <+> pretty ms+      , "result      :" <+> pretty (listToMaybe ms)       ]     -- Return the first display form that matches.     return $ listToMaybe ms@@ -96,7 +108,7 @@     -- identifiers coming from the source term.     wellScoped scope (Display _ _ d)       | isWithDisplay d = True-      | otherwise       = all (inScope scope) $ namesIn d+      | otherwise       = getAll $ namesIn' (All . inScope scope) d  -- all names in d should be in scope      inScope scope x = not $ null $ inverseScopeLookupName x scope @@ -108,68 +120,89 @@ --   i.e., @es / ps = Just us@. matchDisplayForm :: MonadDisplayForm m                  => DisplayForm -> Elims -> MaybeT m (DisplayForm, DisplayTerm)-matchDisplayForm d@(Display _ ps v) es+matchDisplayForm d@(Display n ps v) es   | length ps > length es = mzero   | otherwise             = do       let (es0, es1) = splitAt (length ps) es-      us <- reverse <$> do match ps $ raise 1 es0+      mm <- match (Window 0 n) ps es0+      us <- forM [0 .. n - 1] $ \ i -> do+              -- #5294: Fail if we don't have bindings for all variables. This can+              --        happen outside parameterised modules when some of the parameters+              --        are not used in the lhs.+              Just u <- return $ Map.lookup i mm+              return u       return (d, substWithOrigin (parallelS $ map woThing us) us v `applyE` es1) +type MatchResult = Map Int (WithOrigin Term)++unionMatch :: Monad m => MatchResult -> MatchResult -> MaybeT m MatchResult+unionMatch m1 m2+  | Set.disjoint (Map.keysSet m1) (Map.keysSet m2) = return $ Map.union m1 m2+  | otherwise = mzero  -- Non-linear pattern, fail for now.++unionsMatch :: Monad m => [MatchResult] -> MaybeT m MatchResult+unionsMatch = foldM unionMatch Map.empty++data Window = Window {dbLo, dbHi :: Nat}++inWindow :: Window -> Nat -> Maybe Nat+inWindow (Window lo hi) n | lo <= n, n < hi = Just (n - lo)+                          | otherwise       = Nothing++shiftWindow :: Window -> Window+shiftWindow (Window lo hi) = Window (lo + 1) (hi + 1)+ -- | Class @Match@ for matching a term @p@ in the role of a pattern --   against a term @v@. -----   The 0th variable in @p@ plays the role---   of a place holder (pattern variable).  Each occurrence of---   @var 0@ in @p@ stands for a different pattern variable.------   The result of matching, if successful, is a list of solutions for the---   pattern variables, in left-to-right order.------   The 0th variable is in scope in the input @v@, but should not---   actually occur!---   In the output solution, the @0th@ variable is no longer in scope.---   (It has been substituted by __IMPOSSIBLE__ which corresponds to---   a raise by -1).+--   Free variables inside the window in @p@ are pattern variables and+--   the result of matching is a map from pattern variables (shifted down to start at 0) to subterms+--   of @v@. class Match a where-  match :: MonadDisplayForm m => a -> a -> MaybeT m [WithOrigin Term]+  match :: MonadDisplayForm m => Window -> a -> a -> MaybeT m MatchResult  instance Match a => Match [a] where-  match xs ys = concat <$> zipWithM match xs ys+  match n xs ys = unionsMatch =<< zipWithM (match n) xs ys  instance Match a => Match (Arg a) where-  match p v = map (setOrigin (getOrigin v)) <$> match (unArg p) (unArg v)+  match n p v = Map.map (setOrigin (getOrigin v)) <$> match n (unArg p) (unArg v)  instance Match a => Match (Elim' a) where-  match p v =+  match n p v =     case (p, v) of-      (Proj _ f, Proj _ f') | f == f' -> return []-      (Apply a, Apply a')         -> match a a'-      _                           -> mzero+      (Proj _ f, Proj _ f') | f == f' -> return Map.empty+      _ | Just a  <- isApplyElim p+        , Just a' <- isApplyElim v    -> match n a a'+      -- we do not care to differentiate between Apply and IApply for+      -- printing.+      _                               -> mzero  instance Match Term where-  match p v = lift (instantiate v) >>= \ v -> case (p, v) of-    (Var 0 [], v) -> return [ WithOrigin Inserted $ strengthen __IMPOSSIBLE__ v ]-    (Var i ps, Var j vs) | i == j  -> match ps vs-    (Def c ps, Def d vs) | c == d  -> match ps vs-    (Con c _ ps, Con d _ vs) | c == d -> match ps vs-    (Lit l, Lit l')      | l == l' -> return []-    (p, v)               | p == v  -> return []-    (p, Level l)                   -> match p =<< reallyUnLevelView l-    (Sort ps, Sort pv)             -> match ps pv-    (p, Sort (Type v))             -> match p =<< reallyUnLevelView v+  match w p v = lift (instantiate v) >>= \ v -> case (unSpine p, unSpine v) of+    (Var i [], v)    | Just j <- inWindow w i -> return $ Map.singleton j (WithOrigin Inserted v)+    (Var i (_:_), v) | Just{} <- inWindow w i -> mzero  -- Higher-order pattern, fail for now.+    (Var i ps, Var j vs) | i == j  -> match w ps vs+    (Def c ps, Def d vs) | c == d  -> match w ps vs+    (Con c _ ps, Con d _ vs) | c == d -> match w ps vs+    (Lit l, Lit l')      | l == l' -> return Map.empty+    (Lam h p, Lam h' v)  | h == h' -> match (shiftWindow w) (unAbs p) (unAbs v)+    (p, v)               | p == v  -> return Map.empty  -- TODO: this is wrong (this is why we lifted the rhs before)+    (p, Level l)                   -> match w p =<< reallyUnLevelView l+    (Sort ps, Sort pv)             -> match w ps pv+    (p, Sort (Type v))             -> match w p =<< reallyUnLevelView v     _                              -> mzero  instance Match Sort where-  match p v = case (p, v) of-    (Type pl, Type vl) -> match pl vl-    _ | p == v -> return []+  match w p v = case (p, v) of+    (Type pl, Type vl) -> match w pl vl+    _ | p == v -> return Map.empty     _          -> mzero  instance Match Level where-  match p v = do+  match w p v = do     p <- reallyUnLevelView p     v <- reallyUnLevelView v-    match p v+    match w p v  -- | Substitute terms with origin into display terms, --   replacing variables along with their origins.

src/full/Agda/TypeChecking/DropArgs.hs view

@@ -55,8 +55,8 @@ -- | Use for dropping initial lambdas in clause bodies. --   NOTE: does not reduce term, need lambdas to be present. instance DropArgs Term where-  dropArgs 0 v = v-  dropArgs n v = case v of+  dropArgs 0 = id+  dropArgs n = \case     Lam h b -> dropArgs (n - 1) (absBody b)     _       -> __IMPOSSIBLE__ @@ -71,9 +71,9 @@               | otherwise     -> Case (i <&> \ j -> j - n) $ fmap (dropArgs n) br     Done xs t | length xs < n -> __IMPOSSIBLE__               | otherwise     -> Done (drop n xs) t-    Fail                      -> Fail+    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-

src/full/Agda/TypeChecking/Empty.hs view

@@ -9,9 +9,11 @@ import Control.Monad.Except  import Data.Semigroup+import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Position  import Agda.TypeChecking.Monad@@ -22,18 +24,22 @@ import Agda.TypeChecking.Telescope  import Agda.Utils.Either+import Agda.Utils.List import Agda.Utils.Monad +import Agda.Utils.Impossible+ data ErrorNonEmpty-  = Fail              -- ^ Generic failure-  | FailBecause TCErr -- ^ Failure with informative error-  | DontKnow          -- ^ Emptyness check blocked+  = Fail               -- ^ Generic failure+  | FailBecause TCErr  -- ^ Failure with informative error+  | DontKnow Blocker   -- ^ Emptyness check blocked  instance Semigroup ErrorNonEmpty where-  DontKnow        <> _        = DontKnow-  _               <> DontKnow = DontKnow-  FailBecause err <> _        = FailBecause err-  Fail            <> err      = err+  DontKnow u1     <> DontKnow u2  = DontKnow $ u1 <> u2  -- Both must unblock for this to proceed+  e@DontKnow{}    <> _            = e+  _               <> e@DontKnow{} = e+  FailBecause err <> _            = FailBecause err+  Fail            <> err          = err  instance Monoid ErrorNonEmpty where   mempty  = Fail@@ -47,7 +53,7 @@   -> TCM () ensureEmptyType r t = caseEitherM (checkEmptyType r t) failure return   where-  failure DontKnow          = addConstraint $ IsEmpty r t+  failure (DontKnow u)      = addConstraint u $ IsEmpty r t   failure (FailBecause err) = throwError err   failure Fail              = typeError $ ShouldBeEmpty t [] @@ -67,7 +73,7 @@   case mr of      -- If t is blocked or a meta, we cannot decide emptiness now.  Postpone.-    Left (Blocked m t) -> return $ Left DontKnow+    Left (Blocked b t) -> return $ Left (DontKnow b)      -- If t is not a record type, try to split     Left (NotBlocked nb t) -> do@@ -81,17 +87,17 @@       dontAssignMetas $ do         r <- splitLast Inductive tel ps         case r of-          Left UnificationStuck{} -> return $ Left DontKnow+          Left UnificationStuck{} -> return $ Left $ DontKnow $ unblockOnAnyMetaIn tel           Left _                  -> return $ Left Fail           Right cov -> do-            let ps = map (namedArg . last . fromSplitPatterns . scPats) $ splitClauses cov+            let ps = map (namedArg . lastWithDefault __IMPOSSIBLE__ . fromSplitPatterns . scPats) $ splitClauses cov             if (null ps) then return (Right ()) else               Left . FailBecause <$> do typeError_ $ ShouldBeEmpty t ps      -- If t is a record type, see if any of the field types is empty     Right (r, pars, def) -> do-      if recEtaEquality def == NoEta then return $ Left Fail else do-        void <$> do checkEmptyTel range $ recTel def `apply` pars+      if | NoEta{} <- recEtaEquality def -> return $ Left Fail+         | otherwise -> void <$> do checkEmptyTel range $ recTel def `apply` pars  -- | Check whether one of the types in the given telescope is constructor-less --   and if yes, return its index in the telescope (0 = leftmost).

src/full/Agda/TypeChecking/Errors.hs view

@@ -4,32 +4,37 @@  module Agda.TypeChecking.Errors   ( prettyError-  , prettyWarning   , tcErrString   , prettyTCWarnings'   , prettyTCWarnings   , tcWarningsToError-  , applyFlagsToTCWarnings'+  , applyFlagsToTCWarningsPreserving   , applyFlagsToTCWarnings+  , getAllUnsolvedWarnings+  , getAllWarningsPreserving+  , getAllWarnings+  , getAllWarningsOfTCErr   , dropTopLevelModule   , topLevelModuleDropper   , stringTCErr   ) where -import Prelude hiding ( null )+import Prelude hiding ( null, foldl ) +import Control.Monad.Except++import qualified Data.CaseInsensitive as CaseInsens+import Data.Foldable (foldl) import Data.Function-import Data.List (sortBy, isInfixOf, dropWhileEnd)-import Data.List.NonEmpty (NonEmpty(..))+import Data.List (sortBy, dropWhileEnd, intercalate) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe-import Data.Char (toLower) import qualified Data.Set as Set import qualified Text.PrettyPrint.Boxes as Boxes  import Agda.Syntax.Common+import Agda.Syntax.Concrete.Definitions (notSoNiceDeclarations) import Agda.Syntax.Concrete.Pretty (prettyHiding, prettyRelevance)-import Agda.Syntax.Fixity import Agda.Syntax.Notation import Agda.Syntax.Position import qualified Agda.Syntax.Concrete as C@@ -53,13 +58,15 @@ import Agda.TypeChecking.Telescope ( ifPiType ) import Agda.TypeChecking.Reduce (instantiate) -import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.FileName import Agda.Utils.Float  ( toStringWithoutDotZero ) import Agda.Utils.Function+import Agda.Utils.List   ( initLast )+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Null-import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Pretty ( prettyShow, render ) import qualified Agda.Utils.Pretty as P import Agda.Utils.Size @@ -97,10 +104,10 @@     r = nameBindingSite $ qnameName q  tcErrString :: TCErr -> String-tcErrString err = show (getRange err) ++ " " ++ case err of-  TypeError _ cl    -> errorString $ clValue cl-  Exception r s     -> show r ++ " " ++ show s-  IOException _ r e -> show r ++ " " ++ show e+tcErrString err = prettyShow (getRange err) ++ " " ++ case err of+  TypeError _ _ cl  -> errorString $ clValue cl+  Exception r s     -> prettyShow r ++ " " ++ show s+  IOException _ r e -> prettyShow r ++ " " ++ show e   PatternErr{}      -> "PatternErr"  stringTCErr :: String -> TCErr@@ -141,7 +148,6 @@   GenericError{}                           -> "GenericError"   GenericDocError{}                        -> "GenericDocError"   InstanceNoCandidate{}                    -> "InstanceNoCandidate"-  IlltypedPattern{}                        -> "IlltypedPattern"   IllformedProjectionPattern{}             -> "IllformedProjectionPattern"   CannotEliminateWithPattern{}             -> "CannotEliminateWithPattern"   IllegalLetInTelescope{}                  -> "IllegalLetInTelescope"@@ -161,6 +167,7 @@   NeedOptionCopatterns{}                   -> "NeedOptionCopatterns"   NeedOptionRewriting{}                    -> "NeedOptionRewriting"   NeedOptionProp{}                         -> "NeedOptionProp"+  NeedOptionTwoLevel{}                     -> "NeedOptionTwoLevel"   GeneralizeNotSupportedHere{}             -> "GeneralizeNotSupportedHere"   GeneralizeCyclicDependency{}             -> "GeneralizeCyclicDependency"   GeneralizeUnsolvedMeta{}                 -> "GeneralizeUnsolvedMeta"@@ -175,6 +182,7 @@   NoSuchModule{}                           -> "NoSuchModule"   DuplicatePrimitiveBinding{}              -> "DuplicatePrimitiveBinding"   NoSuchPrimitiveFunction{}                -> "NoSuchPrimitiveFunction"+  WrongModalityForPrimitive{}              -> "WrongModalityForPrimitive"   NotAModuleExpr{}                         -> "NotAModuleExpr"   NotAProperTerm                           -> "NotAProperTerm"   InvalidType{}                            -> "InvalidType"@@ -214,6 +222,7 @@   SplitOnUnusableCohesion{}                -> "SplitOnUnusableCohesion"   -- UNUSED: -- SplitOnErased{}                          -> "SplitOnErased"   SplitOnNonVariable{}                     -> "SplitOnNonVariable"+  SplitOnNonEtaRecord{}                    -> "SplitOnNonEtaRecord"   DefinitionIsIrrelevant{}                 -> "DefinitionIsIrrelevant"   DefinitionIsErased{}                     -> "DefinitionIsErased"   VariableIsIrrelevant{}                   -> "VariableIsIrrelevant"@@ -252,17 +261,21 @@   NonFatalErrors{}                         -> "NonFatalErrors"   InstanceSearchDepthExhausted{}           -> "InstanceSearchDepthExhausted"   TriedToCopyConstrainedPrim{}             -> "TriedToCopyConstrainedPrim"+  SortOfSplitVarError{}                    -> "SortOfSplitVarError"  instance PrettyTCM TCErr where   prettyTCM err = case err of     -- Gallais, 2016-05-14     -- Given where `NonFatalErrors` are created, we know for a     -- fact that ̀ws` is non-empty.-    TypeError _ Closure{ clValue = NonFatalErrors ws } -> foldr1 ($$) $ fmap prettyTCM ws+    TypeError loc _ Closure{ clValue = NonFatalErrors ws } -> do+      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc+      foldr1 ($$) $ fmap prettyTCM ws     -- Andreas, 2014-03-23     -- This use of withTCState seems ok since we do not collect     -- Benchmark info during printing errors.-    TypeError s e -> withTCState (const s) $+    TypeError loc s e -> withTCState (const s) $ do+      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc       sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e     Exception r s     -> sayWhere r $ return s     IOException _ r e -> sayWhere r $ fwords $ show e@@ -346,8 +359,7 @@     WrongNamedArgument a xs0 -> fsep $       pwords "Function does not accept argument "       ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"-      ++ if null xs then [] else-         [parens $ fsep $ text "possible arguments:" : map pretty xs]+      ++ [parens $ fsep $ text "possible arguments:" : map pretty xs | not (null xs)]       where       xs = filter (not . isNoName) xs0 @@ -373,15 +385,10 @@       pwords "Failed to infer that constructor pattern "       ++ [prettyA p] ++ pwords " is forced" -    IlltypedPattern p a -> do-      let ho _ _ = fsep $ pwords "Cannot pattern match on functions"-      ifPiType a ho $ {- else -} \ _ -> do-        fsep $ pwords "Type mismatch"-     IllformedProjectionPattern p -> fsep $       pwords "Ill-formed projection pattern " ++ [prettyA p] -    CannotEliminateWithPattern p a -> do+    CannotEliminateWithPattern b p a -> do       let isProj = isJust (isProjP p)       fsep $         pwords "Cannot eliminate type" ++ prettyTCM a : if@@ -407,6 +414,7 @@         A.EqualP{}  -> "equality"         A.AsP _ _ p -> kindOfPattern p         A.PatternSynP{} -> __IMPOSSIBLE__+        A.AnnP _ _ p -> kindOfPattern p      WrongNumberOfConstructorArguments c expect given -> fsep $       pwords "The constructor" ++ [prettyTCM c] ++@@ -416,8 +424,8 @@      CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $       pwords "Can't resolve overloaded constructors targeting the same datatype"-      ++ [(parens $ prettyTCM (qnameToConcrete d)) <> colon]-      ++ map pretty cs+      ++ [parens (prettyTCM (qnameToConcrete d)) <> colon]+      ++ map pretty (List1.toList cs)      DoesNotConstructAnElementOf c t -> fsep $       pwords "The constructor" ++ [prettyTCM c] ++@@ -461,9 +469,10 @@         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-          IsData   -> "(datatype)"-          IsRecord -> "(record)"+          IsDataModule   -> "(datatype)"+          IsRecordModule -> "(record)"      ModuleArityMismatch m EmptyTel args -> fsep $       pwords "The module" ++ [prettyTCM m] ++@@ -474,26 +483,26 @@       [prettyTCM tel]      ShouldBeEmpty t [] -> fsep $-       [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me"+       prettyTCM t : pwords "should be empty, but that's not obvious to me"      ShouldBeEmpty t ps -> fsep (-      [prettyTCM t] +++      prettyTCM t :       pwords "should be empty, but the following constructor patterns are valid:"       ) $$ nest 2 (vcat $ map (prettyPat 0) ps)      ShouldBeASort t -> fsep $-      [prettyTCM t] ++ pwords "should be a sort, but it isn't"+      prettyTCM t : pwords "should be a sort, but it isn't"      ShouldBePi t -> fsep $-      [prettyTCM t] ++ pwords "should be a function type, but it isn't"+      prettyTCM t : pwords "should be a function type, but it isn't"      ShouldBePath t -> fsep $-      [prettyTCM t] ++ pwords "should be a Path or PathP type, but it isn't"+      prettyTCM t : pwords "should be a Path or PathP type, but it isn't"      NotAProperTerm -> fwords "Found a malformed term" -    InvalidTypeSort s -> fsep $ [prettyTCM s] ++ pwords "is not a valid type"-    InvalidType v -> fsep $ [prettyTCM v] ++ pwords "is not a valid type"+    InvalidTypeSort s -> fsep $ prettyTCM s : pwords "is not a valid type"+    InvalidType v -> fsep $ prettyTCM v : pwords "is not a valid type"      FunctionTypeInSizeUniv v -> fsep $       pwords "Functions may not return sizes, thus, function type " ++@@ -516,6 +525,14 @@       pwords "Cannot pattern match because the (refined) argument " ++       [ prettyTCM v ] ++ pwords " is not a variable." +    SplitOnNonEtaRecord q -> fsep $ concat+      [ pwords "Pattern matching on no-eta record type"+      , [ prettyTCM q, parens ("defined at" <+> prettyTCM r) ]+      , pwords "is not allowed"+      , [ parens "to activate, add declaration `pattern` to record definition" ]+      ]+      where r = nameBindingSite $ qnameName q+     DefinitionIsIrrelevant x -> fsep $       "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here" @@ -538,10 +555,10 @@       (Sort s1      , Sort s2      )         | CmpEq  <- cmp              -> prettyTCM $ UnequalSorts s1 s2         | CmpLeq <- cmp              -> prettyTCM $ NotLeqSort s1 s2-      (Sort MetaS{} , t            ) -> prettyTCM $ ShouldBeASort $ El Inf t-      (s            , Sort MetaS{} ) -> prettyTCM $ ShouldBeASort $ El Inf s-      (Sort DefS{}  , t            ) -> prettyTCM $ ShouldBeASort $ El Inf t-      (s            , Sort DefS{}  ) -> prettyTCM $ ShouldBeASort $ El Inf s+      (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 $@@ -586,19 +603,15 @@     NotLeqSort s1 s2 -> fsep $       [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2] -    TooManyFields r missing xs -> fsep $-      pwords "The record type" ++ [prettyTCM r] ++-      pwords "does not have the fields" ++ punctuate comma (map pretty xs) ++-      if null missing then [] else-        pwords "but it would have the fields"  ++ punctuate comma (map pretty missing)+    TooManyFields r missing xs -> prettyTooManyFields r missing xs      DuplicateConstructors xs -> fsep $-      pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) +++      pwords "Duplicate" ++ constructors xs ++ punctuate comma (map pretty xs) ++       pwords "in datatype"+      where+      constructors ys = P.singPlural ys [text "constructor"] [text "constructors"] -    DuplicateFields xs -> fsep $-      pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++-      pwords "in record"+    DuplicateFields xs -> prettyDuplicateFields xs      WithOnFreeVariable e v -> do       de <- prettyA e@@ -612,7 +625,7 @@           pwords " bound in a module telescope (or patterns of a parent clause)"      UnexpectedWithPatterns ps -> fsep $-      pwords "Unexpected with patterns" ++ (punctuate " |" $ map prettyA ps)+      pwords "Unexpected with patterns" ++ punctuate " |" (map prettyA ps)      WithClausePatternMismatch p q -> fsep $       pwords "With clause pattern " ++ [prettyA p] ++@@ -670,17 +683,28 @@     NoSuchPrimitiveFunction x -> fsep $       pwords "There is no primitive function called" ++ [text x] +    WrongModalityForPrimitive x got expect ->+      vcat [ fsep $ pwords "Wrong modality for primitive" ++ [text x]+           , nest 2 $ text $ "Got:      " ++ intercalate ", " gs+           , nest 2 $ text $ "Expected: " ++ intercalate ", " es ]+      where+        (gs, es) = unzip [ p | p@(g, e) <- zip (things got) (things expect), g /= e ]+        things i = [verbalize $ getHiding i,+                    verbalize $ getRelevance i,+                    verbalize $ getQuantity i,+                    verbalize $ getCohesion i]+     BuiltinInParameterisedModule x -> fwords $       "The BUILTIN pragma cannot appear inside a bound context " ++       "(for instance, in a parameterised module or as a local declaration)"      IllegalLetInTelescope tb -> fsep $       -- pwords "The binding" ++-      [pretty tb] +++      pretty tb :       pwords " is not allowed in a telescope here."      IllegalPatternInTelescope bd -> fsep $-      [pretty bd] +++      pretty bd :       pwords " is not allowed in a telescope here."      NoRHSRequiresAbsurdPattern ps -> fwords $@@ -704,12 +728,23 @@              pwords "in any of the following locations:"            ) $$ nest 2 (vcat $ map (text . filePath) files) -    OverlappingProjects f m1 m2 ->-      fsep ( pwords "The file" ++ [text (filePath f)] +++    OverlappingProjects f m1 m2+      | canon d1 == canon d2 -> fsep $ concat+          [ pwords "Case mismatch when accessing file"+          , [ text $ filePath f ]+          , pwords "through module name"+          , [ pure d2 ]+          ]+      | otherwise -> fsep+           ( pwords "The file" ++ [text (filePath f)] ++              pwords "can be accessed via several project roots. Both" ++-             [pretty m1] ++ pwords "and" ++ [pretty m2] +++             [ pure d1 ] ++ pwords "and" ++ [ pure d2 ] ++              pwords "point to this file."            )+      where+      canon = CaseInsens.mk . P.render+      d1 = P.pretty m1+      d2 = P.pretty m2      AmbiguousTopLevelModuleName x files ->       fsep ( pwords "Ambiguous module name. The module name" ++@@ -728,12 +763,25 @@       pwords "However, according to the include path this module should" ++       pwords "be defined in" ++ [text (filePath file') <> "."] -    ModuleNameUnexpected given expected -> fsep $-      pwords "The name of the top level module does not match the file name. The module" ++-      [ pretty given ] ++-      pwords "should probably be named" ++-      [ pretty expected ]+    ModuleNameUnexpected given expected+      | 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 ]+          , pwords "should probably be named"+          , [ pure dExpected ]+          ]+      where+      canon = CaseInsens.mk . P.render+      dGiven    = P.pretty given+      dExpected = P.pretty expected +     ModuleNameDoesntMatchFileName given files ->       fsep (pwords "The name of the top level module does not match the file name. The module" ++            [ pretty given ] ++ pwords "should be defined in one of the following files:")@@ -748,35 +796,41 @@      NotInScope xs ->       -- using the warning version to avoid code duplication-      prettyTCM (NotInScopeW xs)+      prettyWarning (NotInScopeW xs)      NoSuchModule x -> fsep $ pwords "No module" ++ [pretty x] ++ pwords "in scope"      AmbiguousName x ys -> vcat       [ fsep $ pwords "Ambiguous name" ++ [pretty x <> "."] ++                pwords "It could refer to any one of"-      , nest 2 $ vcat $ map nameWithBinding (NonEmpty.toList ys)+      , nest 2 $ vcat $ fmap nameWithBinding ys       , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"       ]      AmbiguousModule x ys -> vcat       [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> "."] ++                pwords "It could refer to any one of"-      , nest 2 $ vcat $ map help (NonEmpty.toList ys)+      , nest 2 $ vcat $ fmap help ys       , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"       ]       where         help :: MonadPretty m => ModuleName -> m Doc         help m = do           anno <- caseMaybeM (isDatatypeModule m) (return empty) $ \case-            IsData   -> return $ "(datatype module)"-            IsRecord -> return $ "(record module)"+            IsDataModule   -> return $ "(datatype module)"+            IsRecordModule -> return $ "(record module)"           sep [prettyTCM m, anno ] -    ClashingDefinition x y -> fsep $+    ClashingDefinition x y suggestion -> fsep $       pwords "Multiple definitions of" ++ [pretty x <> "."] ++       pwords "Previous definition at"-      ++ [prettyTCM $ nameBindingSite $ qnameName y]+      ++ [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."+        ])      ClashingModule m1 m2 -> fsep $       pwords "The modules" ++ [prettyTCM m1, "and", prettyTCM m2]@@ -811,7 +865,7 @@       pwords "Repeated variables in pattern:" ++ map pretty xs      NotAnExpression e -> fsep $-      [pretty e] ++ pwords "is not a valid expression."+      pretty e : pwords "is not a valid expression."      NotAValidLetBinding nd -> fwords $       "Not a valid let-declaration"@@ -833,7 +887,7 @@     AmbiguousParseForApplication es es' -> fsep (       pwords "Don't know how to parse" ++ [pretty_es <> "."] ++       pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ map pretty' es')+      ) $$ nest 2 (vcat $ fmap pretty' es')       where         pretty_es :: MonadPretty m => m Doc         pretty_es = pretty $ C.RawApp noRange es@@ -842,14 +896,14 @@         pretty' e = do           p1 <- pretty_es           p2 <- pretty e-          if show p1 == show p2 then unambiguous e else pretty e+          if render p1 == render p2 then unambiguous e else return p2          unambiguous :: MonadPretty m => C.Expr -> m Doc         unambiguous e@(C.OpApp r op _ xs)           | all (isOrdinary . namedArg) xs =             pretty $               foldl (C.App r) (C.Ident op) $-                (map . fmap . fmap) fromOrdinary xs+                (fmap . fmap . fmap) fromOrdinary xs           | any (isPlaceholder . namedArg) xs =               pretty e <+> "(section)"         unambiguous e = pretty e@@ -875,41 +929,48 @@     CannotResolveAmbiguousPatternSynonym defs -> vcat       [ fsep $ pwords "Cannot resolve overloaded pattern synonym" ++ [prettyTCM x <> comma] ++                pwords "since candidates have different shapes:"-      , nest 2 $ vcat $ map prDef (NonEmpty.toList defs)+      , nest 2 $ vcat $ fmap prDef defs       , fsep $ pwords "(hint: overloaded pattern synonyms must be equal up to variable and constructor names)"       ]       where         (x, _) = NonEmpty.head defs-        prDef (x, (xs, p)) = prettyA (A.PatternSynDef x xs p) <?> ("at" <+> pretty r)+        prDef (x, (xs, p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) <?> ("at" <+> pretty r)           where r = nameBindingSite $ qnameName x      UnusedVariableInPatternSynonym -> fsep $       pwords "Unused variable in pattern synonym." -    NoParseForLHS IsLHS p -> fsep (-      pwords "Could not parse the left-hand side" ++ [pretty p])--    NoParseForLHS IsPatSyn p -> fsep (-      pwords "Could not parse the pattern synonym" ++ [pretty p])+    NoParseForLHS lhsOrPatSyn errs p -> vcat+      [ fsep $ pwords "Could not parse the" ++ prettyLhsOrPatSyn ++ [pretty p]+      , prettyErrs+      ]+      where+      prettyLhsOrPatSyn = pwords $ case lhsOrPatSyn of+        IsLHS    -> "left-hand side"+        IsPatSyn -> "pattern synonym"+      prettyErrs = case errs of+        []     -> empty+        p0 : _ -> fsep $ pwords "Problematic expression:" ++ [pretty p0]  {- UNUSED     NoParseForPatternSynonym p -> fsep $       pwords "Could not parse the pattern synonym" ++ [pretty p] -} -    AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep (-      pwords "Don't know how to parse" ++ [pretty_p <> "."] ++-      pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ map pretty' ps)+    AmbiguousParseForLHS lhsOrPatSyn p ps -> do+      d <- pretty p+      vcat $+        [ fsep $+            pwords "Don't know how to parse" ++ [pure d <> "."] +++            pwords "Could mean any one of:"+        ]+          +++        map (nest 2 . pretty' d) ps       where-        pretty_p :: MonadPretty m => m Doc-        pretty_p = pretty p--        pretty' :: MonadPretty m => C.Pattern -> m Doc-        pretty' p' = do-          p1 <- pretty_p-          p2 <- pretty p'-          pretty $ if show p1 == show p2 then unambiguousP p' else p'+        pretty' :: MonadPretty m => Doc -> C.Pattern -> m Doc+        pretty' d1 p' = do+          d2 <- pretty p'+          if render d1 == render d2 then pretty $ unambiguousP p' else return d2          -- the entire pattern is shown, not just the ambiguous part,         -- so we need to dig in order to find the OpAppP's.@@ -937,7 +998,7 @@                    map (Boxes.vcat Boxes.left) [col1, col2, col3]) $                unzip3 $                map prettySect $-               sortBy (compare `on` show . notaName . sectNotation) $+               sortBy (compare `on` prettyShow . notaName . sectNotation) $                filter (not . closedWithoutHoles) sects))       where       trimLeft  = dropWhile isNormalHole@@ -984,13 +1045,20 @@         section = qualifyFirstIdPart                     (foldr (\x s -> C.nameToRawName x ++ "." ++ s)                            ""-                           (init (C.qnameParts (notaName nota))))-                    (trim (notation nota))+                           (List1.init (C.qnameParts (notaName nota))))+                    (spacesBetweenAdjacentIds $+                     trim (notation nota))          qualifyFirstIdPart _ []              = []         qualifyFirstIdPart q (IdPart x : ps) = IdPart (fmap (q ++) x) : ps         qualifyFirstIdPart q (p : ps)        = p : qualifyFirstIdPart q ps +        spacesBetweenAdjacentIds (IdPart x : ps@(IdPart _ : _)) =+          IdPart x : IdPart (unranged " ") : spacesBetweenAdjacentIds ps+        spacesBetweenAdjacentIds (p : ps) =+          p : spacesBetweenAdjacentIds ps+        spacesBetweenAdjacentIds [] = []+         trim = case sectKind sect of           InfixNotation   -> trimLeft . trimRight           PrefixNotation  -> trimRight@@ -998,9 +1066,7 @@           NonfixNotation  -> id           NoNotation      -> __IMPOSSIBLE__ -        (names, name) = case Set.toList $ notaNames nota of-          [] -> __IMPOSSIBLE__-          ns -> (init ns, last ns)+        (names, name) = fromMaybe __IMPOSSIBLE__ $ initLast $ Set.toList $ notaNames nota          strut = Boxes.emptyBox (length names) 0 @@ -1091,8 +1157,11 @@     NeedOptionProp       -> fsep $       pwords "Universe Prop is disabled (use options --prop and --no-prop to enable/disable Prop)" +    NeedOptionTwoLevel   -> fsep $+      pwords "Universe SSet is disabled (use option --two-level to enable SSet)"+     GeneralizeNotSupportedHere x -> fsep $-      pwords $ "Generalizable variable " ++ show x ++ " is not supported here"+      pwords $ "Generalizable variable " ++ prettyShow x ++ " is not supported here"      GeneralizeCyclicDependency -> fsep $       pwords "Cyclic dependency between generalized variables"@@ -1118,6 +1187,7 @@      TriedToCopyConstrainedPrim q -> fsep $       pwords "Cannot create a module containing a copy of" ++ [prettyTCM q]+    SortOfSplitVarError _ doc -> return doc      where     mpar n args@@ -1191,12 +1261,13 @@   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     NotADatatype t -> enterClosure t $ \ t -> fsep $       pwords "Cannot split on argument of non-datatype" ++ [prettyTCM t] -    IrrelevantDatatype t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM t]+    BlockedType b t -> enterClosure t $ \ t -> fsep $+      pwords "Cannot split on argument of unresolved type" ++ [prettyTCM t]      ErasedDatatype causedByWithoutK t -> enterClosure t $ \ t -> fsep $       pwords "Cannot branch on erased argument of datatype" ++@@ -1214,7 +1285,7 @@       pwords "because it has no constructor"  -} -    UnificationStuck c tel cIxs gIxs errs+    UnificationStuck b c tel cIxs gIxs errs       | length cIxs /= length gIxs -> __IMPOSSIBLE__       | otherwise                  -> vcat . concat $         [ [ fsep . concat $@@ -1226,14 +1297,15 @@           ]         , zipWith prEq cIxs gIxs         , if null errs then [] else-            [ fsep $ pwords "Possible" ++ pwords (P.singPlural errs "reason" "reasons") ++-                     pwords "why unification failed:" ] +++            fsep ( pwords "Possible" ++ pwords (P.singPlural errs "reason" "reasons") +++                     pwords "why unification failed:" ) :             map (nest 2 . prettyTCM) errs         ]       where         -- Andreas, 2019-08-08, issue #3943         -- To not print hidden indices just as {_}, we strip the Arg and print         -- the hiding information manually.+        prEq :: Arg Term -> Arg Term -> m Doc         prEq cIx gIx = addContext tel $ nest 2 $ hsep [ pr cIx , "≟" , pr gIx ]         pr arg = prettyRelevance arg . prettyHiding arg id <$> prettyTCM (unArg arg) @@ -1252,6 +1324,7 @@       pwords "Case to handle:") $$ nest 2 (vcat $ [display cl])                                 $$ ((pure msg <+> enterClosure t displayAbs) <> ".")         where+        displayAbs :: Abs Type -> m Doc         displayAbs (Abs x t) = addContext x $ prettyTCM t         displayAbs (NoAbs x t) = prettyTCM t         display (tel, ps) = prettyTCM $ NamedClause f True $

src/full/Agda/TypeChecking/EtaContract.hs view

@@ -5,13 +5,16 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic+ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce.Monad () --instance only import {-# SOURCE #-} Agda.TypeChecking.Records import {-# SOURCE #-} Agda.TypeChecking.Datatypes+ import Agda.Utils.Monad+import Agda.Utils.List (initLast)  import Agda.Utils.Impossible @@ -29,8 +32,10 @@   -- At least record constructors should be fully applied where possible!   -- TODO: also for ordinary constructors (\ x -> suc x  vs.  suc)?   Con c ci xs-    | null (conFields c) -> appE (Con c ci) xs-    | otherwise          -> noApp+    | IsData <- conDataRecord c+             -> appE (Con c ci) xs+    | otherwise+             -> noApp   Lit _      -> noApp   Level _    -> noApp   -- could be an application, but let's not eta contract levels   Lam _ _    -> noApp@@ -41,12 +46,8 @@   Dummy{}    -> __IMPOSSIBLE__   where     noApp = NoApp t-    app f [] = noApp-    app f xs = App (f $ init xs) (last xs)-    appE f [] = noApp-    appE f xs-      | Apply v <- last xs = App (f $ init xs) v-      | otherwise          = noApp+    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 #-}@@ -57,7 +58,7 @@ {-# SPECIALIZE etaOnce :: Term -> TCM Term #-} {-# SPECIALIZE etaOnce :: Term -> ReduceM Term #-} etaOnce :: (MonadTCEnv m, HasConstInfo m, HasOptions m) => Term -> m Term-etaOnce v = case v of+etaOnce = \case   -- Andreas, 2012-11-18: this call to reportSDoc seems to cost me 2%   -- performance on the std-lib   -- reportSDoc "tc.eta" 70 $ "eta-contracting" <+> prettyTCM v@@ -66,8 +67,8 @@   -- Andreas, 2012-12-18:  Abstract definitions could contain   -- abstract records whose constructors are not in scope.   -- To be able to eta-contract them, we ignore abstract.-  Con c ci es -> do-    etaCon c ci es etaContractRecord+  Con c ci es -> etaCon c ci es etaContractRecord+   v -> return v  -- | If record constructor, call eta-contraction function.@@ -79,7 +80,7 @@               -- ^ Eta-contraction workhorse, gets also name of record type.   -> m Term   -- ^ Returns @Con c ci args@ or its eta-contraction. etaCon c ci es cont = ignoreAbstractMode $ do-  let fallback = return $ Con c ci $ es+  let fallback = return $ Con c ci es   -- reportSDoc "tc.eta" 20 $ "eta-contracting record" <+> prettyTCM t   r <- getConstructorData $ conName c -- fails in ConcreteMode if c is abstract   ifNotM (isEtaRecord r) fallback $ {-else-} do@@ -106,7 +107,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@@ -117,9 +118,5 @@     -- is in fact @Level@, e.g. @\(A : Set) → F lzero@ should not be     -- eta-contracted to @F@.     -- isVar0 True Level{}               = True-    isVar0 tyty (Level (Max 0 [Plus 0 l])) = case l of-      NeutralLevel _ v -> isVar0 tyty v-      UnreducedLevel v -> isVar0 tyty v-      BlockedLevel{}   -> False-      MetaLevel{}      -> False+    isVar0 tyty (Level (Max 0 [Plus 0 l])) = isVar0 tyty l     isVar0 _ _ = False

src/full/Agda/TypeChecking/EtaExpand.hs view

@@ -12,9 +12,7 @@ import Agda.TypeChecking.Substitute  -- | Eta-expand a term if its type is a function type or an eta-record type.-etaExpandOnce-  :: (MonadReduce m, MonadTCEnv m, HasOptions m, HasConstInfo m, MonadDebug m)-  => Type -> Term -> m Term+etaExpandOnce :: PureTCM m => Type -> Term -> m Term etaExpandOnce a v = reduce a >>= \case   El _ (Pi a b) -> return $     Lam ai $ mkAbs (absName b) $ raise 1 v `apply` [ Arg ai $ var 0 ]@@ -32,11 +30,5 @@ deepEtaExpand :: Term -> Type -> TCM Term deepEtaExpand v a = checkInternal' etaExpandAction v CmpLeq a -etaExpandAction-  :: (MonadReduce m, MonadTCEnv m, HasOptions m, HasConstInfo m, MonadDebug m)-  => Action m-etaExpandAction = Action-  { preAction       = etaExpandOnce-  , postAction      = \ _ -> return-  , relevanceAction = \ _ -> id-  }+etaExpandAction :: PureTCM m => Action m+etaExpandAction = defaultAction { preAction = etaExpandOnce  }

src/full/Agda/TypeChecking/Forcing.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-}  {-| A constructor argument is forced if it appears as pattern variable in an index of the target.@@ -64,33 +63,21 @@     isForced,     nextIsForced ) where -import Control.Arrow (first)-import Control.Monad-import Control.Monad.Trans.Maybe-import Control.Monad.Writer (WriterT(..), tell, lift)-import Data.Foldable as Fold hiding (any)-import Data.Maybe-import Data.List ((\\))-import Data.Function (on)-import Data.Monoid+import Data.Monoid -- for (<>) in GHC 8.0.2  import Agda.Interaction.Options  import Agda.Syntax.Common-import Agda.Syntax.Position import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Pretty hiding ((<>)) -import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Monad+import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size  import Agda.Utils.Impossible@@ -101,44 +88,44 @@ --   are in normal form. computeForcingAnnotations :: QName -> Type -> TCM [IsForced] computeForcingAnnotations c t =-  ifNotM (optForcing <$> pragmaOptions) {-then-} (return []) $ {-else-} do-  -- Andreas, 2015-03-10  Normalization prevents Issue 1454.-  -- t <- normalise t-  -- Andreas, 2015-03-28  Issue 1469: Normalization too costly.-  -- Instantiation also fixes Issue 1454.-  -- Note that normalization of s0 below does not help.-  t <- instantiateFull t-  -- Ulf, 2018-01-28 (#2919): We do need to reduce the target type enough to-  -- get to the actual data type.-  -- Also #2947: The type might reduce to a pi type.-  TelV tel (El _ a) <- telViewPath t-  let vs = case a of-        Def _ us -> us-        _        -> __IMPOSSIBLE__-      n  = size tel-      xs :: [(Modality, Nat)]-      xs = forcedVariables vs-      -- #2819: We can only mark an argument as forced if it appears in the-      -- type with a relevance below (i.e. more relevant) than the one of the-      -- constructor argument. Otherwise we can't actually get the value from-      -- the type. Also the argument shouldn't be irrelevant, since in that-      -- case it isn't really forced.-      isForced :: Modality -> Nat -> Bool-      isForced m i = and-        [ hasQuantity0 m || noUserQuantity m   -- User can disable forcing by giving quantity explicitly.-        , getRelevance m /= Irrelevant-        , any (\ (m', j) -> i == j && m' `moreUsableModality` m) xs-        ]-      forcedArgs =-        [ if isForced m i then Forced else NotForced-        | (i, m) <- zip (downFrom n) $ map getModality (telToList tel)-        ]-  reportS "tc.force" 60-    [ "Forcing analysis for " ++ show c-    , "  xs          = " ++ show (map snd xs)-    , "  forcedArgs  = " ++ show forcedArgs-    ]-  return forcedArgs+  ifNotM (optForcing <$> pragmaOptions {-then-}) (return []) $ {-else-} do+    -- Andreas, 2015-03-10  Normalization prevents Issue 1454.+    -- t <- normalise t+    -- Andreas, 2015-03-28  Issue 1469: Normalization too costly.+    -- Instantiation also fixes Issue 1454.+    -- Note that normalization of s0 below does not help.+    t <- instantiateFull t+    -- Ulf, 2018-01-28 (#2919): We do need to reduce the target type enough to+    -- get to the actual data type.+    -- Also #2947: The type might reduce to a pi type.+    TelV tel (El _ a) <- telViewPath t+    let vs = case a of+          Def _ us -> us+          _        -> __IMPOSSIBLE__+        n = size tel+        xs :: [(Modality, Nat)]+        xs = forcedVariables vs+        -- #2819: We can only mark an argument as forced if it appears in the+        -- type with a relevance below (i.e. more relevant) than the one of the+        -- constructor argument. Otherwise we can't actually get the value from+        -- the type. Also the argument shouldn't be irrelevant, since in that+        -- case it isn't really forced.+        isForced :: Modality -> Nat -> Bool+        isForced m i =+               (hasQuantity0 m || noUserQuantity m)+            && (getRelevance m /= Irrelevant)+            && any (\(m', j) -> i == j+            && m' `moreUsableModality` m) xs+        forcedArgs =+          [ if isForced m i then Forced else NotForced+          | (i, m) <- zip (downFrom n) $ map getModality (telToList tel)+          ]+    reportS "tc.force" 60+      [ "Forcing analysis for " ++ prettyShow c+      , "  xs          = " ++ show (map snd xs)+      , "  forcedArgs  = " ++ show forcedArgs+      ]+    return forcedArgs  -- | Compute the pattern variables of a term or term-like thing. class ForcedVariables a where@@ -156,13 +143,13 @@   forcedVariables Proj{}    = []  instance ForcedVariables a => ForcedVariables (Arg a) where-  forcedVariables x = [ (m <> m', i) | (m', i) <- forcedVariables (unArg x) ]+  forcedVariables x = [ (composeModality m m', i) | (m', i) <- forcedVariables (unArg x) ]     where m = getModality x  -- | Assumes that the term is in normal form. instance ForcedVariables Term where-  forcedVariables t = case t of-    Var i [] -> [(mempty, i)]+  forcedVariables = \case+    Var i [] -> [(unitModality, i)]     Con _ _ vs -> forcedVariables vs     _ -> [] @@ -173,4 +160,3 @@ nextIsForced :: [IsForced] -> (IsForced, [IsForced]) nextIsForced []     = (NotForced, []) nextIsForced (f:fs) = (f, fs)-

src/full/Agda/TypeChecking/Free.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE UndecidableInstances       #-} -- Due to underdetermined var in IsVarSet multi-param typeclass  -- | Computing the free variables of a term. --@@ -47,6 +46,7 @@     , runFree, rigidVars, stronglyRigidVars, unguardedVars, allVars     , allFreeVars     , allRelevantVars, allRelevantVarsIgnoring+    , freeVarsIgnore     , freeIn, freeInIgnoringSorts, isBinderUsed     , relevantIn, relevantInIgnoringSortAnn     , FlexRig'(..), FlexRig@@ -61,17 +61,11 @@  import Prelude hiding (null) ----import Data.Monoid ( Monoid, mempty, mappend) import Data.Semigroup ( Semigroup, (<>), Any(..), All(..) ) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap--  import qualified Agda.Benchmarking as Bench

src/full/Agda/TypeChecking/Free/Lazy.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE TypeFamilies               #-}  -- | Computing the free variables of a term lazily. --@@ -66,12 +63,10 @@ import Control.Monad.Reader  -import Data.Foldable (Foldable, foldMap) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet-import Data.Monoid ( Monoid, mempty, mappend, mconcat ) import Data.Semigroup ( Semigroup, (<>) )  @@ -83,6 +78,7 @@ import Agda.Utils.Lens import Agda.Utils.Monad import Agda.Utils.Null+import Agda.Utils.Semigroup import Agda.Utils.Singleton import Agda.Utils.Size @@ -272,11 +268,11 @@ -- | 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') (m <> m')+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 mempty+oneVarOcc = VarOcc Unguarded unitModality  --------------------------------------------------------------------------- -- * Storing variable occurrences (semimodule).@@ -422,7 +418,7 @@ initFreeEnv e sing = FreeEnv   { feExtra       = e   , feFlexRig     = Unguarded-  , feModality    = mempty            -- multiplicative monoid+  , feModality    = unitModality      -- multiplicative monoid   , feSingleton   = maybe mempty sing   } @@ -433,9 +429,6 @@ runFreeM :: IsVarSet a c => SingleVar c -> IgnoreSorts -> FreeM a c -> c runFreeM single i m = runReader m $ initFreeEnv i single -instance (Applicative m, Semigroup c) => Semigroup (FreeT a b m c) where-  (<>) = liftA2 (<>)- instance (Functor m, Applicative m, Monad m, Semigroup c, Monoid c) => Monoid (FreeT a b m c) where   mempty  = pure mempty   mappend = (<>)@@ -478,13 +471,16 @@ underFlexRig = local . over lensFlexRig . composeFlexRig . view lensFlexRig  -- | What happens to the variables occurring under a constructor?-underConstructor :: (MonadReader r m, LensFlexRig a r, Semigroup a) => ConHead -> m z -> m z-underConstructor (ConHead c i fs) =-  case (i,fs) of+underConstructor :: (MonadReader r m, LensFlexRig a r, 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+    CoInductive -> underFlexRig WeaklyRigid     -- Inductive constructors do not admit infinite cycles:-    (Inductive, _)    -> underFlexRig StronglyRigid+    Inductive   | size es == size 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@@ -492,7 +488,6 @@     -- -- Inductive record constructors do not admit infinite cycles,     -- -- but this cannot be proven inside Agda.     -- -- Thus, unification should not prove it either.-    -- (Inductive, (_:_)) -> id  --------------------------------------------------------------------------- -- * Recursively collecting free variables.@@ -519,13 +514,13 @@     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      -> freeVars' t+    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 $ freeVars' ts+    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).@@ -534,25 +529,27 @@     Sort s       -> freeVars' s     Level l      -> freeVars' l     MetaV m ts   -> underFlexRig (Flexible $ singleton m) $ freeVars' ts-    DontCare mt  -> underModality (Modality Irrelevant mempty mempty) $ freeVars' mt+    DontCare mt  -> underModality (Modality Irrelevant unitQuantity unitCohesion) $ freeVars' mt     Dummy{}      -> mempty  instance Free t => Free (Type' t) where   freeVars' (El s t) =-    ifM ((IgnoreNot ==) <$> asks feIgnoreSorts)+    ifM (asks ((IgnoreNot ==) . feIgnoreSorts))       {- then -} (freeVars' (s, t))       {- else -} (freeVars' t)  instance Free Sort where   freeVars' s =-    ifM ((IgnoreAll ==) <$> asks feIgnoreSorts) mempty $ {- else -}+    ifM (asks ((IgnoreAll ==) . feIgnoreSorts)) mempty $ {- else -}     case s of       Type a     -> freeVars' a       Prop a     -> freeVars' a-      Inf        -> mempty+      Inf _ _    -> mempty+      SSet a     -> freeVars' a       SizeUniv   -> mempty-      PiSort a s -> underFlexRig (Flexible mempty) (freeVars' $ unDom a) `mappend`-                    underFlexRig WeaklyRigid (freeVars' (getSort a, s))+      LockUniv   -> 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@@ -562,19 +559,13 @@ instance Free Level where   freeVars' (Max _ as) = freeVars' as -instance Free PlusLevel where+instance Free t => Free (PlusLevel' t) where   freeVars' (Plus _ l)    = freeVars' l -instance Free LevelAtom where-  freeVars' l = case l of-    MetaLevel m vs   -> underFlexRig (Flexible $ singleton m) $ freeVars' vs-    NeutralLevel _ v -> freeVars' v-    BlockedLevel _ v -> freeVars' v-    UnreducedLevel v -> freeVars' v- instance Free t => Free [t]            where instance Free t => Free (Maybe t)      where instance Free t => Free (WithHiding t) where+instance Free t => Free (Named nm t)  instance (Free t, Free u) => Free (t, u) where   freeVars' (t, u) = freeVars' t `mappend` freeVars' u@@ -605,5 +596,7 @@   freeVars' cl = underBinder' (size $ clauseTel cl) $ freeVars' $ clauseBody cl  instance Free EqualityView where-  freeVars' (OtherType t) = freeVars' t-  freeVars' (EqualityType s _eq l t a b) = freeVars' (s, l, [t, a, b])+  freeVars' = \case+    OtherType t -> freeVars' t+    IdiomType t -> freeVars' t+    EqualityType s _eq l t a b -> freeVars' (s, l, [t, a, b])

src/full/Agda/TypeChecking/Free/Precompute.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-} -- | Precompute free variables in a term (and store in 'ArgInfo'). module Agda.TypeChecking.Free.Precompute   ( PrecomputeFreeVars, precomputeFreeVars@@ -7,7 +6,6 @@ import Control.Monad.Writer import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet-import Data.Traversable (Traversable, traverse)  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -78,9 +76,11 @@     case s of       Type a     -> Type <$> precomputeFreeVars a       Prop a     -> Prop <$> precomputeFreeVars a-      Inf        -> pure s+      Inf _ _    -> pure s+      SSet a     -> SSet <$> precomputeFreeVars a       SizeUniv   -> pure s-      PiSort a s -> uncurry PiSort <$> precomputeFreeVars (a, s)+      LockUniv   -> pure s+      PiSort a s1 s2 -> PiSort <$> precomputeFreeVars a <*> precomputeFreeVars s1 <*> precomputeFreeVars s2       FunSort s1 s2 -> uncurry FunSort <$> precomputeFreeVars (s1, s2)       UnivSort s -> UnivSort <$> precomputeFreeVars s       MetaS x es -> MetaS x <$> precomputeFreeVars es@@ -92,14 +92,6 @@  instance PrecomputeFreeVars PlusLevel where   precomputeFreeVars (Plus n l) = Plus n <$> precomputeFreeVars l--instance PrecomputeFreeVars LevelAtom where-  precomputeFreeVars l =-    case l of-      MetaLevel x es   -> MetaLevel x <$> precomputeFreeVars es-      BlockedLevel x t -> BlockedLevel x <$> precomputeFreeVars t-      NeutralLevel b t -> NeutralLevel b <$> precomputeFreeVars t-      UnreducedLevel t -> UnreducedLevel <$> precomputeFreeVars t  instance PrecomputeFreeVars Type where   precomputeFreeVars (El s t) = uncurry El <$> precomputeFreeVars (s, t)

src/full/Agda/TypeChecking/Free/Reduce.hs view

@@ -1,3 +1,4 @@+ -- | 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@@ -13,7 +14,6 @@ import Data.IntMap (IntMap) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet)-import Data.Traversable (traverse)  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -51,7 +51,7 @@   , MonadReduce m   ) -class (PrecomputeFreeVars a, Subst Term a) => ForceNotFree a where+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@@ -62,7 +62,7 @@ -- Return the set of variables for which there is still hope that they -- may not occur. varsToForceNotFree :: (MonadFreeRed m) => m IntSet-varsToForceNotFree = IntMap.keysSet . (IntMap.filter (== NotFree)) <$> get+varsToForceNotFree = gets (IntMap.keysSet . (IntMap.filter (== NotFree)))  -- Reduce the argument if there are offending free variables. Doesn't call the -- continuation when no reduction is required.@@ -71,9 +71,10 @@ reduceIfFreeVars k a = do   xs <- varsToForceNotFree   let fvs     = precomputedFreeVars a-      notfree = IntSet.null $ IntSet.intersection xs fvs-  if | notfree   -> return a-     | otherwise -> k . precomputeFreeVars_ =<< reduce a+      notfree = IntSet.disjoint xs fvs+  if notfree+    then return a+    else k . precomputeFreeVars_ =<< reduce a  -- Careful not to define forceNotFree' = forceNotFreeR since that would loop. forceNotFreeR :: (Reduce a, ForceNotFree a, MonadFreeRed m)@@ -85,7 +86,7 @@   -- traverse.   forceNotFree' = reduceIfFreeVars (traverse forceNotFree') -instance (Reduce a, ForceNotFree a) => ForceNotFree (Dom a) where+instance (Reduce a, ForceNotFree a, TermSubst a) => ForceNotFree (Dom a) where   forceNotFree' = traverse forceNotFreeR  instance (Reduce a, ForceNotFree a) => ForceNotFree (Abs a) where@@ -112,7 +113,7 @@   forceNotFree' (El s t) = El <$> forceNotFree' s <*> forceNotFree' t  instance ForceNotFree Term where-  forceNotFree' t = case t of+  forceNotFree' = \case     Var x es   -> do       metas <- ask       modify $ IntMap.adjust (const $ MaybeFree metas) x@@ -126,8 +127,8 @@     Sort s     -> Sort     <$> forceNotFree' s     Level l    -> Level    <$> forceNotFree' l     DontCare t -> DontCare <$> forceNotFreeR t  -- Reduction stops at DontCare so reduceIf-    Lit{}      -> return t-    Dummy{}    -> return t+    t@Lit{}    -> return t+    t@Dummy{}  -> return t  instance ForceNotFree Level where   forceNotFree' (Max m as) = Max m <$> forceNotFree' as@@ -135,25 +136,19 @@ instance ForceNotFree PlusLevel where   forceNotFree' (Plus k a) = Plus k <$> forceNotFree' a -instance ForceNotFree LevelAtom where-  forceNotFree' l = case l of-    MetaLevel x es   -> local (insertMetaSet x) $-                        MetaLevel x    <$> forceNotFree' es-    BlockedLevel x t -> BlockedLevel x <$> forceNotFree' t-    NeutralLevel b t -> NeutralLevel b <$> forceNotFree' t-    UnreducedLevel t -> UnreducedLevel <$> forceNotFreeR t  -- Already reduce in the cases above- instance ForceNotFree Sort where   -- Reduce for sorts already goes under all sort constructors, so we can get   -- away without forceNotFreeR here.-  forceNotFree' s = case s of+  forceNotFree' = \case     Type l     -> Type     <$> forceNotFree' l     Prop l     -> Prop     <$> forceNotFree' l-    PiSort a b -> PiSort   <$> forceNotFree' a <*> forceNotFree' b+    SSet l     -> SSet     <$> 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-    Inf        -> return s-    SizeUniv   -> return s-    DummyS{}   -> return s+    s@(Inf _ _)-> return s+    s@SizeUniv -> return s+    s@LockUniv -> return s+    s@DummyS{} -> return s

src/full/Agda/TypeChecking/Functions.hs view

@@ -38,12 +38,12 @@ etaExpandClause :: MonadTCM tcm => Clause -> tcm Clause etaExpandClause clause = liftTCM $ do   case clause of-    Clause _  _  ctel ps _           Nothing  _ _ _ _ -> return clause-    Clause _  _  ctel ps Nothing     (Just t) _ _ _ _ -> return clause-    Clause rl rf ctel ps (Just body) (Just t) catchall recursive unreachable ell -> do+    Clause _  _  ctel ps _           Nothing  _ _ _ _ _ -> return clause+    Clause _  _  ctel ps Nothing     (Just t) _ _ _ _ _ -> return clause+    Clause rl rf ctel ps (Just body) (Just t) catchall exact recursive unreachable ell -> do        -- Get the telescope to expand the clause with.-      TelV tel0 t' <- telView $ unArg t+      TelV tel0 t' <- addContext ctel $ telView $ unArg t        -- If the rhs has lambdas, harvest the names of the bound variables.       let xs   = peekLambdas body@@ -58,11 +58,11 @@           body' = raise n body `apply` teleArgs tel       reportSDoc "term.clause.expand" 30 $ inTopContext $ vcat         [ "etaExpandClause"-        , "  body    = " <+> (addContext ctel' $ prettyTCM body)+        , "  body    = " <+> addContext ctel' (prettyTCM body)         , "  xs      = " <+> text (prettyShow xs)         , "  new tel = " <+> prettyTCM ctel'         ]-      return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall recursive unreachable ell+      return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall exact recursive unreachable ell   where     -- Get all initial lambdas of the body.     peekLambdas :: Term -> [Arg ArgName]

src/full/Agda/TypeChecking/Generalize.hs view

@@ -8,6 +8,8 @@  import Control.Arrow (first) import Control.Monad+import Control.Monad.Except+ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.Set (Set)@@ -41,7 +43,7 @@  import Agda.Benchmarking (Phase(Typing, Generalize)) import Agda.Utils.Benchmark-import Agda.Utils.Except+import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.List   (hasElem)@@ -50,6 +52,7 @@ import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Permutation+import Agda.Utils.Pretty (prettyShow)   -- | Generalize a telescope over a set of generalizable variables.@@ -119,7 +122,7 @@    reportSDoc "tc.generalize" 40 $ vcat     [ "generalized"-    , nest 2 $ "t =" <+> escapeContext __IMPOSSIBLE__ 1 (prettyTCM t') ]+    , nest 2 $ "t =" <+> escapeContext impossible 1 (prettyTCM t') ]    return (genTelNames, t', userdata) @@ -155,10 +158,20 @@   -- Pair metas with their metaInfo   mvs <- mapM ((\ x -> (x,) <$> lookupMeta x) . MetaId) $ IntSet.toList allmetas -  constrainedMetas <- Set.unions <.> mapM (constraintMetas . clValue . theConstraint) =<<-                        ((++) <$> useTC stAwakeConstraints-                              <*> useTC stSleepingConstraints)+  -- Issue 4727: filter out metavariables that were created before the+  -- current checkpoint, since they are too old to be generalized.+  -- TODO: make metasCreatedBy smarter so it doesn't see pruned+  -- versions of old metas as new metas.+  cp <- viewTC eCurrentCheckpoint+  let isFreshMeta (x,mv) = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp+  mvs <- filterM isFreshMeta mvs+  cs <- (++) <$> useTC stAwakeConstraints+             <*> useTC stSleepingConstraints +  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) @@ -168,7 +181,7 @@       -- want the nice error from checking the constraint after generalization.       -- See #3276.       isGeneralizable (x, mv) = Map.member x nameMap ||-                                not (isConstrained x) && YesGeneralize == unArg (miGeneralizable (mvInfo mv))+                                not (isConstrained x) && NoGeneralize /= unArg (miGeneralizable (mvInfo mv))       isSort = isSortMeta_ . snd       isOpen = isOpenMeta . mvInstantiation . snd @@ -207,7 +220,7 @@                   (Just IdS, Perm m xs)        -> xs == [0 .. m - 1]                   (Just (Wk n IdS), Perm m xs) -> xs == [0 .. m - n - 1]                   _                            -> False-          when (not sameContext) $ do+          unless sameContext $ do             ty <- getMetaType x             let Perm m xs = mvPermutation mv             reportSDoc "tc.generalize" 20 $ vcat@@ -222,16 +235,19 @@     case mvInstantiation mv of       InstV _ v -> do         parentName <- getMetaNameSuggestion x-        metas <- filterM canGeneralize . allMetasList =<< instantiateFull v+        metas <- filterM canGeneralize . Set.toList . allMetas Set.singleton =<< instantiateFull v         let suggestNames i [] = return ()-            suggestNames i (m : ms)  = do-              name <- getMetaNameSuggestion m-              case name of-                "" -> do-                  setMetaNameSuggestion m (parentName ++ "." ++ show i)-                  suggestNames (i + 1) ms-                _  -> suggestNames i ms-        Set.fromList metas <$ suggestNames 1 metas+            suggestNames i (m : ms) = do+              -- #4291: Override existing meta name suggestion. If we solved the parent with a new+              --        meta use the parent name for that, otherwise suffix with a number.+              let suf | null ms && i == 1, MetaV{} <- v = ""+                      | otherwise                       = "." ++ show i+              setMetaNameSuggestion m (parentName ++ suf)+              suggestNames (i + 1) ms+        unless (null metas) $+          reportSDoc "tc.generalize" 40 $ hcat ["Inherited metas from ", prettyTCM x, ":"] <?> prettyList_ (map prettyTCM metas)+                                    -- Don't suggest names for explicitly named generalizable metas+        Set.fromList metas <$ suggestNames 1 (filter (`Map.notMember` nameMap) metas)       _ -> __IMPOSSIBLE__    let (alsoGeneralize, reallyDontGeneralize) = partition (`Set.member` inherited) $ map fst nongeneralizableOpen@@ -286,7 +302,9 @@     args <- getContextArgs     fmap concat $ forM sortedMetas $ \ m -> do       mv   <- lookupMeta m-      let info = getArgInfo $ miGeneralizable $ mvInfo mv+      let info =+            hideOrKeepInstance $+            getArgInfo $ miGeneralizable $ mvInfo mv           HasType{ jMetaType = t } = mvJudgement mv           perm = mvPermutation mv       t' <- piApplyM t $ permute (takeP (length args) perm) args@@ -301,7 +319,7 @@   let inscope (ii, InteractionPoint{ipMeta = Just x})         | IntSet.member (metaId x) allmetas = [(x, ii)]       inscope _ = []-  ips <- Map.fromList . concatMap inscope . Map.toList <$> useTC stInteractionPoints+  ips <- Map.fromList . concatMap inscope . BiMap.toList <$> useTC stInteractionPoints   pruneUnsolvedMetas genRecName genRecCon genTel genRecFields ips shouldGeneralize allSortedMetas    -- Fill in the missing details of the telescope record.@@ -334,18 +352,25 @@      sub = unpackSub genRecCon $ map getArgInfo $ telToList genTel -    prepruneError :: MetaId -> String -> TCM a-    prepruneError x code = do+    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-      let msg = "Congratulations! You have found an easter egg (#" ++ code ++ "). " ++-                "Be the first to submit a self-contained test case (max 50 lines of code) " ++-                "producing this error message to https://github.com/agda/agda/issues/3672 " ++-                "to receive a small prize."-          cause = "The error is caused by complicated dependencies between unsolved " ++-                  "metavariables and generalized variables. In particular, this meta:"       genericDocError =<<-        (fwords msg $+$-         sep [fwords cause, nest 2 $ prettyTCM (MetaV x []) <+> "at" <+> pretty r]+        (fwords (msg ++ " The problematic unsolved meta is") $$+                 (nest 2 $ prettyTCM (MetaV x []) <+> "at" <+> pretty r)         )      -- If one of the fields depend on this meta, we have to make sure that this meta doesn't depend@@ -361,7 +386,7 @@         case δ of           Wk n IdS -> return (n, _A)           IdS      -> return (0, _A)-          _        -> prepruneError x "RFCX"+          _        -> prepruneErrorRefinedContext x       if i == 0 then return x else do         reportSDoc "tc.generalize.prune.pre" 40 $ vcat           [ "prepruning"@@ -375,13 +400,13 @@          -- 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 -> prepruneError x "FVTY"+          Just (j, _) | j < i -> prepruneErrorCyclicDependencies x           _                   -> return ()          -- If it doesn't we can strenghten it to the current context (this is done by         -- newMetaFromOld).         --   Γ (r : GenRec) ⊢ ρ : Γ (r : GenRec) Δ-        let ρ  = strengthenS __IMPOSSIBLE__ i+        let ρ  = strengthenS impossible i             ρ' = raiseS i          (y, u) <- newMetaFromOld mv ρ _A@@ -398,7 +423,7 @@           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` \ _ -> prepruneError x "INST"+          noConstraints (doPrune x mv _A v uρ') `catchError` \ _ -> prepruneErrorFailedToInstantiate x           setInteractionPoint x y           return y @@ -449,7 +474,7 @@         -- σ is the unpacking substitution (which is polymorphic in Γ)         let σ   = sub (size _Θ)             --    Γ <- Γ (r : GenTel) Δ <- Γ₀ (r : GenTel) <- Γ₀-            γ   = strengthenS __IMPOSSIBLE__ (i + 1) `composeS` δ `composeS` raiseS 1+            γ   = strengthenS impossible (i + 1) `composeS` δ `composeS` raiseS 1             _Θγ = applySubst γ _Θ             _Δσ = applySubst σ _Δ @@ -527,10 +552,10 @@     findGenRec :: MetaVariable -> TCM (Maybe Int)     findGenRec mv = do       cxt <- instantiateFull =<< getContext-      let notPruned = [ i | i <- permute (takeP (length cxt) $ mvPermutation mv) $-                                 reverse $ zipWith const [0..] cxt ]+      let notPruned = permute (takeP (length cxt) $ mvPermutation mv) $+               reverse $ zipWith const [0..] cxt       case [ i | (i, Dom{unDom = (_, El _ (Def q _))}) <- zip [0..] cxt,-                 q == genRecName, elem i notPruned ] of+                 q == genRecName, i `elem` notPruned ] of         []    -> return Nothing         _:_:_ -> __IMPOSSIBLE__         [i]   -> return (Just i)@@ -539,7 +564,7 @@     newMetaFromOld mv ρ mA = setCurrentRange mv $       case mA of         Nothing -> do-          s @ (MetaS y _) <- newSortMeta+          s@(MetaS y _) <- newSortMeta           return (y, Sort s)         Just _A -> do           let _Aρ = applySubst ρ _A@@ -577,7 +602,7 @@           names   = map (fst . unDom) telList           late    = map (fst . unDom) $ filter (getAny . allMetas (Any . (== x))) telList           projs (Proj _ q)-            | elem q genRecFields = Set.fromList [x | Just x <- [getGeneralizedFieldName q]]+            | q `elem` genRecFields = Set.fromList $ catMaybes [getGeneralizedFieldName q]           projs _                 = Set.empty           early = Set.toList $ flip foldTerm u $ \ case                   Var _ es   -> foldMap projs es@@ -612,8 +637,8 @@     addNamedVariablesToScope cxt =       forM_ cxt $ \ Dom{ unDom = (x, _) } -> do         -- Recognize named variables by lack of '.' (TODO: hacky!)-        reportSLn "tc.generalize.eta.scope" 40 $ "Adding (or not) " ++ show (nameConcrete x) ++ " to the scope"-        when ('.' `notElem` show (nameConcrete x)) $ do+        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 @@ -659,7 +684,7 @@ -- | Create metas for all used generalizable variables and their dependencies. createGenValues :: Set QName -> TCM (Map MetaId QName, Map QName GeneralizedValue) createGenValues s = do-  genvals <- locallyTC eGeneralizeMetas (const YesGeneralize) $+  genvals <- locallyTC eGeneralizeMetas (const YesGeneralizeVar) $                forM (sortBy (compare `on` getRange) $ Set.toList s) createGenValue   let metaMap = Map.fromList [ (m, x) | (x, m, _) <- genvals ]       nameMap = Map.fromList [ (x, v) | (x, _, v) <- genvals ]@@ -685,11 +710,15 @@   args <- newTelMeta argTel   metaType <- piApplyM ty args -  let name     = show (nameConcrete $ qnameName x)+  let name     = prettyShow (nameConcrete $ qnameName x)   (m, term) <- newNamedValueMeta DontRunMetaOccursCheck name CmpLeq metaType -  -- Freeze the meta to prevent named generalizable metas to be instantiated.-  updateMetaVar m $ \ mv -> mv { mvFrozen = Frozen }+  -- Freeze the meta to prevent named generalizable metas from being+  -- instantiated, and set the quantity of the meta to the declared+  -- quantity of the generalisable variable.+  updateMetaVar m $ \ mv ->+    setQuantity (getQuantity (defArgInfo def)) $+    mv { mvFrozen = Frozen }    -- Set up names of arg metas   forM_ (zip3 [1..] (map unArg args) (telToList argTel)) $ \ case@@ -702,7 +731,7 @@    -- Update the ArgInfos for the named meta. The argument metas are   -- created with the correct ArgInfo.-  setMetaArgInfo m $ hideExplicit (defArgInfo def)+  setMetaGeneralizableArgInfo m $ hideExplicit (defArgInfo def)    reportSDoc "tc.generalize" 50 $ vcat     [ "created metas for generalized variable" <+> prettyTCM x@@ -728,8 +757,10 @@   genRecName   <- freshQName "GeneralizeTel"   genRecCon    <- freshQName "mkGeneralizeTel" <&> \ con -> ConHead                   { conName      = con+                  , conDataRecord= IsRecord CopatternMatching                   , conInductive = Inductive-                  , conFields    = map argFromDom genRecFields }+                  , conFields    = map argFromDom genRecFields+                  }   projIx <- succ . size <$> getContext   inTopContext $ forM_ (zip sortedMetas genRecFields) $ \ (meta, fld) -> do     fieldTy <- getMetaType meta@@ -778,14 +809,15 @@            , recTel          = dummyTel (length genRecFields) -- Filled in later            , recMutual       = Just []            , recEtaEquality' = Inferred YesEta+           , recPatternMatching = CopatternMatching            , recInduction    = Nothing            , recAbstr        = ConcreteDef            , recComp         = emptyCompKit            }   reportSDoc "tc.generalize" 20 $ vcat-    [ text "created genRec" <+> prettyList_ (map (text . show . unDom) genRecFields) ]+    [ text "created genRec" <+> prettyList_ (map (text . prettyShow . unDom) genRecFields) ]   reportSDoc "tc.generalize" 80 $ vcat-    [ text "created genRec" <+> text (show genRecFields) ]+    [ text "created genRec" <+> text (prettyShow genRecFields) ]   -- Solve the genRecMeta   args <- getContextArgs   let genRecTy = El genRecSort $ Def genRecName $ map Apply args@@ -803,7 +835,7 @@           abstract cxtTel (El s $ Pi (defaultDom recTy) (Abs "r" $ unDom ty)) :           mkFieldTypes flds (absApp ftel proj)         where-          s = PiSort (defaultDom recTy) (Abs "r" $ getSort ty)+          s = mkPiSort (defaultDom recTy) (Abs "r" $ unDom ty)           proj = Var 0 [Proj ProjSystem fld]       mkFieldTypes _ _ = __IMPOSSIBLE__   let fieldTypes = mkFieldTypes fields (raise 1 fieldTel)

src/full/Agda/TypeChecking/IApplyConfluence.hs view

@@ -5,32 +5,20 @@  import Control.Monad import Control.Arrow (first,second)-import Control.Monad.Reader-import Control.Monad.Trans ( lift ) -import Data.Either (lefts) import qualified Data.List as List-import Data.Monoid (Any(..))-import Data.Map (Map) import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Traversable as Trav  import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Internal.Generic--- import Agda.Syntax.Literal import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern  import Agda.Interaction.Options  import Agda.TypeChecking.Primitive hiding (Nat)--- import Agda.TypeChecking.Primitive.Cubical import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Conversion (equalTermOnFace) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce@@ -39,6 +27,7 @@ import Agda.TypeChecking.Conversion import Agda.TypeChecking.Substitute +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Maybe@@ -63,7 +52,7 @@       modifySignature $ updateDefinition f $ updateTheDef         $ updateCovering (const []) -      traceCall (CheckFunDefCall (getRange f) f []) $+      traceCall (CheckFunDefCall (getRange f) f [] False) $         forM_ cls $ checkIApplyConfluence f     _ -> return () @@ -170,7 +159,7 @@                                              ipc@IPClause{ipcBoundary = b}                                                -> ipc {ipcBoundary = b ++ cs'}                                              ipc@IPNoClause{} -> ipc}-                modifyInteractionPoints (Map.adjust f ii)+                modifyInteractionPoints (BiMap.adjust f ii)               _ -> return ()  @@ -207,7 +196,7 @@     bindS binds = parallelS (for [0..maximum (-1:map fst binds)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i binds)))      codomain :: Substitution-             -> [Nat] -- ^ support+             -> [Nat]  -- support              -> Context -> Context     codomain s vs cxt = map snd $ filter (\ (i,c) -> i `List.notElem` vs) $ zip [0..] cxt'      where@@ -224,12 +213,17 @@                   mTel0 <- getContextTelescope                   unless (size mTel0 == size es_m) $ reportSDoc "tc.iapply.ip.meta" 20 $ "funny number of elims" <+> text (show (size mTel0, size es_m))                   unless (size mTel0 <= size es_m) $ __IMPOSSIBLE__ -- meta has at least enough arguments to fill its creation context.+                  reportSDoc "tc.iapply.ip.meta" 20 $ "ty: " <+> prettyTCM ty                    -- if we have more arguments we extend the telescope accordingly.                   TelV mTel1 _ <- telViewUpToPath (size es_m) ty                   addContext (mTel1 `apply` teleArgs mTel0) $ do                   mTel <- getContextTelescope+                  reportSDoc "tc.iapply.ip.meta" 20 $ "mTel: " <+> prettyTCM mTel++                  es_m <- return $ take (size mTel) es_m                   -- invariant: size mTel == size es_m+                   (c,cxt) <- enterClosure cl $ \ c -> (c,) <$> getContextTelescope                   reportSDoc "tc.iapply.ip.meta" 20 $ prettyTCM cxt

src/full/Agda/TypeChecking/Implicit.hs view

@@ -5,8 +5,12 @@ module Agda.TypeChecking.Implicit where  import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class +import Agda.Syntax.Position (beginningOf, getRange) import Agda.Syntax.Common+import Agda.Syntax.Abstract (Binder, mkBinder_) import Agda.Syntax.Internal as I  import Agda.TypeChecking.Irrelevance@@ -16,17 +20,71 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Telescope  import Agda.Utils.Functor+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Tuple +-- Cut and paste from insertImplicitPatternsT:++-- | Insert implicit binders in a list of binders, but not at the end.+insertImplicitBindersT+  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)+  => [NamedArg Binder]     -- ^ Should be non-empty, otherwise nothing happens.+  -> Type                  -- ^ Function type eliminated by arguments given by binders.+  -> m [NamedArg Binder] -- ^ Padded binders.+insertImplicitBindersT = \case+  []     -> \ _ -> return []+  b : bs -> List1.toList <.> insertImplicitBindersT1 (b :| bs)++-- | Insert implicit binders in a list of binders, but not at the end.+insertImplicitBindersT1+  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)+  => List1 (NamedArg Binder)        -- ^ Non-empty.+  -> Type                           -- ^ Function type eliminated by arguments given by binders.+  -> m (List1 (NamedArg Binder))  -- ^ Padded binders.+insertImplicitBindersT1 bs@(b :| _) a = setCurrentRange b $ do+  TelV tel ty0 <- telViewUpTo' (-1) (not . visible) a+  reportSDoc "tc.term.lambda.imp" 20 $+    vcat [ "insertImplicitBindersT"+         , nest 2 $ "bs  = " <+> do+             brackets $ fsep $ punctuate comma $ fmap prettyA bs+         , nest 2 $ "tel = " <+> prettyTCM tel+         , nest 2 $ "ty  = " <+> addContext tel (prettyTCM ty0)+         ]+  reportSDoc "tc.term.lambda.imp" 70 $+    vcat [ "insertImplicitBindersT"+         , nest 2 $ "bs  = " <+> (text . show . List1.toList) bs+         , nest 2 $ "tel = " <+> (text . show) tel+         , nest 2 $ "ty  = " <+> (text . show) ty0+         ]+  hs <- insImp b tel+  -- Continue with implicit binders inserted before @b@.+  let bs0@(b1 :| bs1) = List1.prepend hs bs+  reduce a >>= piOrPath >>= \case+    -- If @a@ is a function (or path) type, continue inserting after @b1@.+    Left (_, ty) -> (b1 :|) <$> insertImplicitBindersT bs1 (absBody ty)+    -- Otherwise, we are done.+    Right{}      -> return bs0+  where+  insImp b EmptyTel = return []+  insImp b tel = case insertImplicit b $ telToList tel of+    BadImplicits   -> typeError WrongHidingInLHS+    NoSuchName x   -> typeError WrongHidingInLHS+    ImpInsert doms -> mapM implicitArg doms+      where+      implicitArg d = setOrigin Inserted . unnamedArg (domInfo d) . mkBinder_ <$> do+        freshNoName $ beginningOf $ getRange b+ -- | @implicitArgs n expand t@ generates up to @n@ implicit argument --   metas (unbounded if @n<0@), as long as @t@ is a function type --   and @expand@ holds on the hiding info of its domain.  implicitArgs-  :: (MonadReduce m, MonadMetaSolver m, MonadDebug m, MonadTCM m)+  :: (PureTCM m, MonadMetaSolver m, MonadTCM m)   => 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.@@ -39,7 +97,7 @@ --   and @expand@ holds on the hiding and name info of its domain.  implicitNamedArgs-  :: (MonadReduce m, MonadMetaSolver m, MonadDebug m, MonadTCM m)+  :: (PureTCM m, MonadMetaSolver m, MonadTCM m)   => 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.@@ -70,15 +128,18 @@ -- | Create a metavariable according to the 'Hiding' info.  newMetaArg-  :: MonadMetaSolver m+  :: (PureTCM m, MonadMetaSolver m)   => ArgInfo    -- ^ Kind/relevance 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 info x cmp a = do-  prp <- isPropM a-  let irrelevantIfProp = if prp then applyRelevanceToContext Irrelevant else id+  prp <- runBlocked $ isPropM a+  let irrelevantIfProp =+        if prp == Right True+        then applyRelevanceToContext Irrelevant+        else id   applyModalityToContext info $ irrelevantIfProp $     newMeta (getHiding info) (argNameToString x) a   where@@ -154,9 +215,9 @@       takeHiddenUntil (sameHiding a) ts      where-    -- | @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.+    -- @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.     --     --   Precondition: @p@ should imply @not . visible@.     takeHiddenUntil :: (Dom ArgName -> Bool) -> [Dom ArgName] -> Maybe [Dom ()]

src/full/Agda/TypeChecking/Injectivity.hs view

@@ -40,12 +40,11 @@  module Agda.TypeChecking.Injectivity where -import Prelude hiding (mapM)- import Control.Applicative+import Control.Monad.Except import Control.Monad.Fail-import Control.Monad.State hiding (mapM, forM)-import Control.Monad.Reader hiding (mapM, forM)+import Control.Monad.State+import Control.Monad.Reader import Control.Monad.Trans.Maybe  import qualified Data.Map as Map@@ -61,7 +60,6 @@  import Agda.TypeChecking.Irrelevance (isIrrelevantOrPropM) import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce import {-# SOURCE #-} Agda.TypeChecking.MetaVars@@ -70,7 +68,7 @@ import Agda.TypeChecking.Polarity import Agda.TypeChecking.Warnings -import Agda.Utils.Except ( MonadError )+import Agda.Utils.Either import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe@@ -107,6 +105,7 @@             if Set.member f fs then no else yes         Function{}    -> no         Primitive{}   -> no+        PrimitiveSort{} -> no         GeneralizableVar{} -> __IMPOSSIBLE__         Constructor{} -> __IMPOSSIBLE__         AbstractDefn{}-> __IMPOSSIBLE__@@ -126,7 +125,7 @@ -- | Do a full whnf and treat neutral terms as rigid. Used on the arguments to --   an injective functions and to the right-hand side. headSymbol'-  :: (MonadReduce m, MonadError TCErr m, MonadDebug m, HasBuiltins m)+  :: (PureTCM m, MonadError TCErr m)   => Term -> m (Maybe TermHead) headSymbol' v = do   v <- traverse constructorForm =<< reduceB v@@ -141,8 +140,8 @@       Lit _      -> return Nothing       Lam{}      -> return Nothing       Level{}    -> return Nothing-      MetaV{}    -> return Nothing       DontCare{} -> return Nothing+      MetaV{}    -> __IMPOSSIBLE__       Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s  -- | Does deBruijn variable i correspond to a top-level argument, and if so@@ -165,7 +164,7 @@  checkInjectivity :: QName -> [Clause] -> TCM FunctionInverse checkInjectivity f cs0-  | null $ filter properlyMatchingClause cs = do+  | not (any properlyMatchingClause cs) = do       reportSLn "tc.inj.check.pointless" 35 $         "Injectivity of " ++ prettyShow (A.qnameToConcrete f) ++ " would be pointless."       return NotInjective@@ -190,7 +189,8 @@    -- We don't need to consider absurd clauses   let computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = do-        h <- ifM (isIrrelevantOrPropM tbody) (return UnknownHead) $+        maybeIrr <- fromRight (const True) <.> runBlocked $ isIrrelevantOrPropM tbody+        h <- if maybeIrr then return UnknownHead else           varToArg c =<< do             lift $ fromMaybe UnknownHead <$> do               addContext (clauseTel c) $@@ -241,9 +241,10 @@         Function{}     -> False         Datatype{}     -> True         Record{}       -> True-        Constructor{conSrcCon = ConHead{ conFields = fs }}-                       -> null fs   -- Record constructors can be eliminated by projections+        Constructor{conSrcCon = ConHead{ conDataRecord = d, conFields = fs }}+                       -> d == IsData || null fs   -- Record constructors can be eliminated by projections         Primitive{}    -> False+        PrimitiveSort{} -> __IMPOSSIBLE__         GeneralizableVar{} -> __IMPOSSIBLE__  @@ -254,7 +255,7 @@ --   deBruijn variables. Checks that the instantiated heads are still rigid and --   distinct. instantiateVarHeads-  :: forall m c. (MonadReduce m, MonadError TCErr m, MonadDebug m, HasBuiltins m)+  :: forall m c. (PureTCM m, MonadError TCErr m)   => QName -> Elims -> InversionMap c -> m (Maybe (InversionMap c)) instantiateVarHeads f es m = runMaybeT $ updateHeads (const . instHead) m   where@@ -266,9 +267,9 @@  -- | Argument should be in weak head normal form. functionInverse-  :: (MonadReduce m, MonadError TCErr m, HasBuiltins m, HasConstInfo m)+  :: (PureTCM m, MonadError TCErr m)   => Term -> m InvView-functionInverse v = case v of+functionInverse = \case   Def f es -> do     inv <- defInverse <$> getConstInfo f     case inv of@@ -282,10 +283,9 @@ data InvView = Inv QName [Elim] (InversionMap Clause)              | NoInv --- | Precondition: The first argument must be blocked and the second must be---                 neutral.-useInjectivity :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()-useInjectivity dir ty blk neu = locallyTC eInjectivityDepth succ $ do+-- | 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 dir blocker ty blk neu = locallyTC eInjectivityDepth succ $ do   inv <- functionInverse blk   -- Injectivity might cause non-termination for unsatisfiable constraints   -- (#431, #3067). Look at the number of active problems and the injectivity@@ -303,9 +303,6 @@         pwords "useInjectivity on" ++         [ prettyTCM blk, prettyTCM cmp, prettyTCM neu, prettyTCM ty]       let canReduceToSelf = Map.member (ConsHead f) hdMap || Map.member UnknownHead hdMap-          allUnique       = all isUnique hdMap-          isUnique [_] = True-          isUnique _   = False       case neu of         -- f us == f vs  <=>  us == vs         -- Crucially, this relies on `f vs` being neutral and only works@@ -343,13 +340,15 @@           Just hd -> invertFunction cmp blk inv hd fallback err success             where err = typeError $ app (\ u v -> UnequalTerms cmp u v ty) blk neu   where-    fallback     = addConstraint $ app (ValueCmp cmp ty) blk neu+    fallback     = addConstraint blocker $ app (ValueCmp cmp ty) blk neu     success blk' = app (compareAs cmp ty) blk' neu -    (cmp, app) = case dir of+    cmpApp :: (Comparison, (a -> a -> b) -> a -> a -> b)+    cmpApp = case dir of       DirEq -> (CmpEq, id)       DirLeq -> (CmpLeq, id)       DirGeq -> (CmpLeq, flip)+    (cmp, app) = cmpApp  -- | The second argument should be a blocked application and the third argument --   the inverse of the applied function.

src/full/Agda/TypeChecking/InstanceArguments.hs view

@@ -7,26 +7,29 @@   , postponeInstanceConstraints   ) where +import Control.Monad.Except import Control.Monad.Reader import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List+import Data.Bifunctor+import Data.Foldable (toList) import Data.Function (on) import Data.Monoid hiding ((<>)) -import Agda.Interaction.Options (optOverlappingInstances)+import Agda.Interaction.Options (optOverlappingInstances, optQualifiedInstances)  import Agda.Syntax.Common+import Agda.Syntax.Concrete.Name (isQualified) import Agda.Syntax.Position import Agda.Syntax.Internal as I import Agda.Syntax.Internal.MetaVars-import Agda.Syntax.Scope.Base (isNameInScope)+import Agda.Syntax.Scope.Base (isNameInScope, inverseScopeLookupName', AllowAmbiguousNames(..))  import Agda.TypeChecking.Errors () --instance only import Agda.TypeChecking.Implicit (implicitArgs) import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Records@@ -40,7 +43,6 @@ import Agda.TypeChecking.Monad.Benchmark (billTo)  import Agda.Utils.Either-import Agda.Utils.Except import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad@@ -52,63 +54,63 @@ -- | Compute a list of instance candidates. --   'Nothing' if target type or any context type is a meta, error if --   type is not eligible for instance search.-initialInstanceCandidates :: Type -> TCM (Maybe [Candidate])+initialInstanceCandidates :: Type -> TCM (Either Blocker [Candidate]) initialInstanceCandidates t = do   (_ , otn) <- getOutputTypeName t   case otn of     NoOutputTypeName -> typeError $ GenericError $       "Instance search can only be used to find elements in a named type"-    OutputTypeNameNotYetKnown -> do+    OutputTypeNameNotYetKnown b -> do       reportSDoc "tc.instance.cands" 30 $ "Instance type is not yet known. "-      return Nothing+      return (Left b)     OutputTypeVisiblePi -> typeError $ GenericError $       "Instance search cannot be used to find elements in an explicit function type"     OutputTypeVar    -> do       reportSDoc "tc.instance.cands" 30 $ "Instance type is a variable. "-      maybeRight <$> runExceptT getContextVars+      runBlocked getContextVars     OutputTypeName n -> do       reportSDoc "tc.instance.cands" 30 $ "Found instance type head: " <+> prettyTCM n-      runExceptT getContextVars >>= \case-        Left b -> return Nothing-        Right ctxVars -> Just . (ctxVars ++) <$> getScopeDefs n+      runBlocked getContextVars >>= \case+        Left b -> return $ Left b+        Right ctxVars -> Right . (ctxVars ++) <$> getScopeDefs n   where     -- get a list of variables with their type, relative to current context-    getContextVars :: ExceptT Blocked_ TCM [Candidate]+    getContextVars :: BlockT TCM [Candidate]     getContextVars = do       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 = [ (var i, raise (i + 1) t) | (i, t) <- zip [0..] ctx ]-          vars = [ Candidate x t (isOverlappable info)+          vars = [ Candidate LocalCandidate x t (isOverlappable info)                  | (x, Dom{domInfo = info, unDom = (_, t)}) <- varsAndRaisedTypes                  , isInstance info                  , usableModality info                  ]        -- {{}}-fields of variables are also candidates-      let cxtAndTypes = [ (x, t) | (x, Dom{unDom = (_, t)}) <- varsAndRaisedTypes ]+      let cxtAndTypes = [ (LocalCandidate, x, t) | (x, Dom{unDom = (_, t)}) <- varsAndRaisedTypes ]       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-              [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM v <+> ":"+              [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":"                     , nest 2 $ prettyTCM t                     ]-              | Candidate v t overlap <- fields+              | c@(Candidate q v t overlap) <- fields               ]        -- get let bindings       env <- asksTC envLetBindings-      env <- mapM (getOpen . snd) $ Map.toList env-      let lets = [ Candidate v t False-                 | (v, Dom{domInfo = info, unDom = t}) <- env+      env <- mapM (traverse getOpen) $ Map.toList env+      let lets = [ Candidate LocalCandidate v t False+                 | (_,(v, Dom{domInfo = info, unDom = t})) <- env                  , isInstance info                  , usableModality info                  ]       return $ vars ++ fields ++ lets -    etaExpand :: (MonadTCM m, MonadReduce m, HasConstInfo m, HasBuiltins m)+    etaExpand :: (MonadTCM m, PureTCM m)               => Bool -> Type -> m (Maybe (QName, Args))     etaExpand etaOnce t =       isEtaRecordType t >>= \case@@ -119,24 +121,24 @@               m <- currentModule               -- Are we inside the record module? If so it's safe and desirable               -- to eta-expand once (issue #2320).-              if qnameToList r `List.isPrefixOf` mnameToList m+              if qnameToList0 r `List.isPrefixOf` mnameToList m                 then return (Just (r, vs))                 else return Nothing         r -> return r -    instanceFields :: (Term,Type) -> ExceptT Blocked_ TCM [Candidate]+    instanceFields :: (CandidateKind,Term,Type) -> BlockT TCM [Candidate]     instanceFields = instanceFields' True -    instanceFields' :: Bool -> (Term,Type) -> ExceptT Blocked_ TCM [Candidate]-    instanceFields' etaOnce (v, t) =-      ifBlocked t (\m _ -> throwError $ Blocked m ()) $ \ _ t -> do+    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 (unArg arg) t (isOverlappable arg)+          ([ Candidate LocalCandidate (unArg arg) t (isOverlappable arg)            | isInstance arg ] ++) <$>-          instanceFields' False (unArg arg, t)+          instanceFields' False (LocalCandidate, unArg arg, t)      getScopeDefs :: QName -> TCM [Candidate]     getScopeDefs n = do@@ -147,6 +149,10 @@      candidate :: Relevance -> QName -> TCM (Maybe Candidate)     candidate rel q = ifNotM (isNameInScope q <$> getScope) (return Nothing) $ do+      -- Jesper, 2020-03-16: When using --no-qualified-instances,+      -- filter out instances that are only in scope under a qualified+      -- name.+      filterQualified $ do       -- Andreas, 2012-07-07:       -- we try to get the info for q       -- while opening a module, q may be in scope but not in the signature@@ -169,12 +175,25 @@                -- Ulf, 2014-08-20: constructors are always instances.                Constructor{ conSrcCon = c }       -> Con c ConOSystem []                _                                  -> Def q $ map Apply args-          return $ Just $ Candidate v t False+          return $ Just $ Candidate (GlobalCandidate q) v t False       where         -- unbound constant throws an internal error-        handle (TypeError _ (Closure {clValue = InternalError _})) = return Nothing-        handle err                                                 = throwError err+        handle (TypeError _ _ (Closure {clValue = InternalError _})) = return Nothing+        handle err                                                   = throwError err +        filterQualified :: TCM (Maybe Candidate) -> TCM (Maybe Candidate)+        filterQualified m = ifM (optQualifiedInstances <$> pragmaOptions) m $ do+          qc <- inverseScopeLookupName' AmbiguousAnything q <$> getScope+          let isQual = maybe True isQualified $ listToMaybe qc+          reportSDoc "tc.instance.qualified" 30 $+            if isQual then+              "dropping qualified instance" <+> prettyTCM q+            else+              "keeping instance" <+> prettyTCM q <+>+              "since it is in scope as" <+> prettyTCM qc+          if isQual then return Nothing else m++ -- | @findInstance m (v,a)s@ tries to instantiate on of the types @a@s --   of the candidate terms @v@s to the type @t@ of the metavariable @m@. --   If successful, meta @m@ is solved with the instantiation of @v@.@@ -199,23 +218,23 @@     TelV tel t <- telViewUpTo' (-1) notVisible t     cands <- addContext tel $ initialInstanceCandidates t     case cands of-      Nothing -> do+      Left unblock -> do         reportSLn "tc.instance" 20 "Can't figure out target of instance goal. Postponing constraint."-        addConstraint $ FindInstance m Nothing Nothing-      Just {} -> findInstance m cands+        addConstraint unblock $ FindInstance m Nothing+      Right cs -> findInstance m (Just cs) -findInstance m (Just cands) =-  whenJustM (findInstance' m cands) $ (\ (cands, b) -> addConstraint $ FindInstance m b $ Just cands)+findInstance m (Just cands) =                          -- Note: if no blocking meta variable this will not unblock until the end of the mutual block+  whenJustM (findInstance' m cands) $ (\ (cands, b) -> addConstraint b $ FindInstance m $ Just cands)  -- | Result says whether we need to add constraint, and if so, the set of --   remaining candidates and an eventual blocking metavariable.-findInstance' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Maybe MetaId))+findInstance' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Blocker)) findInstance' m cands = ifM (isFrozen m) (do     reportSLn "tc.instance" 20 "Refusing to solve frozen instance meta."-    return (Just (cands, Nothing))) $ do+    return (Just (cands, neverUnblock))) $ do   ifM shouldPostponeInstanceSearch (do     reportSLn "tc.instance" 20 "Postponing possibly recursive instance search."-    return $ Just (cands, Nothing)) $ billTo [Benchmark.Typing, Benchmark.InstanceSearch] $ do+    return $ Just (cands, neverUnblock)) $ billTo [Benchmark.Typing, Benchmark.InstanceSearch] $ do   -- Andreas, 2015-02-07: New metas should be created with range of the   -- current instance meta, thus, we set the range.   mv <- lookupMeta m@@ -223,19 +242,24 @@       reportSLn "tc.instance" 15 $         "findInstance 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)       reportSDoc "tc.instance" 60 $ nest 2 $ vcat-        [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM v <+> ":"-              , nest 2 $ prettyTCM t ] | Candidate v t overlap <- cands ]+        [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":"+              , nest 2 $ prettyTCM t ] | c@(Candidate q v t overlap) <- cands ]       reportSDoc "tc.instance" 70 $ "raw" $$ do        nest 2 $ vcat-        [ sep [ (if overlap then "overlap" else empty) <+> pretty v <+> ":"-              , nest 2 $ pretty t ] | Candidate v t overlap <- cands ]-      t <- normalise =<< getMetaTypeInContext m+        [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":"+              , nest 2 $ pretty t ] | c@(Candidate q v t overlap) <- cands ]+      t <- getMetaTypeInContext m       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 -      mcands <- checkCandidates m t cands+      mcands <-+        -- Temporarily remove other instance constraints to avoid+        -- redundant solution attempts+        holdConstraints (const isInstanceProblemConstraint) $+        checkCandidates m t cands+       debugConstraints       case mcands of @@ -255,10 +279,10 @@           setCurrentRange (take 1 $ map snd sortedErrs) $             typeError $ InstanceNoCandidate t [ (candidateTerm c, err) | (c, err) <- sortedErrs ] -        Just (_, [Candidate term t' _]) -> do+        Just (_, [c@(Candidate q term t' _)]) -> do           reportSDoc "tc.instance" 15 $ vcat             [ "findInstance 5: solved by instance search using the only candidate"-            , nest 2 $ prettyTCM term+            , nest 2 $ prettyTCM c <+> "=" <+> prettyTCM term             , "of type " <+> prettyTCM t'             , "for type" <+> prettyTCM t             ]@@ -273,12 +297,10 @@           reportSDoc "tc.instance" 15 $             text ("findInstance 5: refined candidates: ") <+>             prettyTCM (List.map candidateTerm cs)-          return (Just (cs, Nothing))+          return (Just (cs, neverUnblock)) --- | Precondition: type is spine reduced and ends in a Def or a Var. insidePi :: Type -> (Type -> TCM a) -> TCM a-insidePi t ret =-  case unEl t of+insidePi t ret = reduce (unEl t) >>= \case     Pi a b     -> addContext (absName b, a) $ insidePi (absBody b) ret     Def{}      -> ret t     Var{}      -> ret t@@ -308,27 +330,31 @@       tryC c = do         ok <- f c         v  <- instantiateFull (MetaV m ctxElims)-        a  <- instantiateFull =<< (`piApplyM` ctxArgs) =<< getMetaType m-        return (ok, v, a)+        return (ok, v)   result <- mapM (\c -> do bs <- localTCStateSaving (tryC c); return (c, bs)) cands    -- Check that there aren't any hard failures-  case [ err | (_, ((HellNo err, _, _), _)) <- result ] of+  case [ err | (_, ((HellNo err, _), _)) <- result ] of     err : _ -> throwError err     []      -> return () -  let result' = [ (c, v, a, s) | (c, ((r, v, a), s)) <- result, not (isNo r) ]+  -- c : Candidate+  -- r : YesNoMaybe+  -- v : Term         (fully instantiated)+  -- a : Type         (fully instantiated)+  -- s : TCState+  let result' = [ (c, v, s) | (c, ((r, v), s)) <- result, not (isNo r) ]   result'' <- dropSameCandidates m result'   case result'' of-    [(c, _, _, s)] -> ([], [c]) <$ putTC s-    _              -> do-      let bad  = [ (c, err) | (c, ((NoBecause err, _, _), _)) <- result ]-          good = [ c | (c, _, _, _) <- result'' ]+    [(c, _, s)] -> ([], [c]) <$ putTC s+    _           -> do+      let bad  = [ (c, err) | (c, ((NoBecause err, _), _)) <- result ]+          good = [ c | (c, _, _) <- result'' ]       return (bad, good)  -- Drop all candidates which are judgmentally equal to the first one. -- This is sufficient to reduce the list to a singleton should all be equal.-dropSameCandidates :: MetaId -> [(Candidate, Term, Type, a)] -> TCM [(Candidate, Term, Type, a)]+dropSameCandidates :: MetaId -> [(Candidate, Term, a)] -> TCM [(Candidate, Term, a)] dropSameCandidates m cands0 = verboseBracket "tc.instance" 30 "dropSameCandidates" $ do   metas <- getMetaVariableSet   -- Does `it` have any metas in the initial meta variable store?@@ -336,34 +362,38 @@    -- Take overlappable candidates into account   let cands =-        case List.partition (\ (c, _, _, _) -> candidateOverlappable c) cands0 of+        case List.partition (\ (c, _, _) -> candidateOverlappable c) cands0 of           (cand : _, []) -> [cand]  -- only overlappable candidates: pick the first one           _              -> cands0  -- otherwise require equality    reportSDoc "tc.instance" 50 $ vcat     [ "valid candidates:"-    , nest 2 $ vcat [ if freshMetas (v, a) then "(redacted)" else-                      sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ]-                    | (_, v, a, _) <- cands ] ]+    , nest 2 $ vcat [ if freshMetas v then "(redacted)" else+                      sep [ prettyTCM v ]+                    | (_, v, _) <- cands ] ]   rel <- getMetaRelevance <$> lookupMeta m   case cands of     []            -> return cands     cvd : _ | isIrrelevant rel -> do-      reportSLn "tc.instance" 30 "Meta is irrelevant so any candidate will do."+      reportSLn "tc.instance" 30 "dropSameCandidates: Meta is irrelevant so any candidate will do."       return [cvd]-    (_, MetaV m' _, _, _) : _ | m == m' ->  -- We didn't instantiate, so can't compare+    (_, MetaV m' _, _) : _ | m == m' -> do  -- We didn't instantiate, so can't compare+      reportSLn "tc.instance" 30 "dropSameCandidates: Meta was not instantiated so we don't filter equal candidates yet"       return cands-    cvd@(_, v, a, _) : vas -> do-        if freshMetas (v, a)-          then return (cvd : vas)-          else (cvd :) <$> dropWhileM equal vas+    cvd@(_, v, _) : vas+      | freshMetas v -> do+          reportSLn "tc.instance" 30 "dropSameCandidates: Solution of instance meta has fresh metas so we don't filter equal candidates yet"+          return (cvd : vas)+      | otherwise -> (cvd :) <$> dropWhileM equal vas       where-        equal (_, v', a', _)-            | freshMetas (v', a') = return False  -- If there are fresh metas we can't compare-            | otherwise           =-          verboseBracket "tc.instance" 30 "comparingCandidates" $ do+        equal :: (Candidate, Term, a) -> TCM Bool+        equal (_, v', _)+            | freshMetas v' = return False  -- If there are fresh metas we can't compare+            | otherwise     =+          verboseBracket "tc.instance" 30 "dropSameCandidates: " $ do           reportSDoc "tc.instance" 30 $ sep [ prettyTCM v <+> "==", nest 2 $ prettyTCM v' ]-          localTCState $ dontAssignMetas $ ifNoConstraints_ (equalType a a' >> equalTerm a v v')+          a <- uncurry piApplyM =<< ((,) <$> getMetaType m <*> getContextArgs)+          localTCState $ dontAssignMetas $ ifNoConstraints_ (equalTerm a v v')                              {- then -} (return True)                              {- else -} (\ _ -> return False)                              `catchError` (\ _ -> return False)@@ -387,18 +417,22 @@     reportSDoc "tc.instance.candidates" 20 $ nest 2 $ "target:" <+> prettyTCM t     reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat       [ "candidates"-      , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM v <+> ":" <+> prettyTCM t-             | Candidate v t overlap <- cands ] ]+      , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t+             | c@(Candidate q v t overlap) <- cands ] ]     cands' <- filterResetingState m cands (checkCandidateForMeta m t)     reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat       [ "valid candidates"+      , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t+             | c@(Candidate q v t overlap) <- snd cands' ] ]+    reportSDoc "tc.instance.candidates" 60 $ nest 2 $ vcat+      [ "valid candidates"       , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM v <+> ":" <+> prettyTCM t-             | Candidate v t overlap <- snd cands' ] ]+             | c@(Candidate q v t overlap) <- snd cands' ] ]     return cands'   where     anyMetaTypes :: [Candidate] -> TCM Bool     anyMetaTypes [] = return False-    anyMetaTypes (Candidate _ a _ : cands) = do+    anyMetaTypes (Candidate _ _ a _ : cands) = do       a <- instantiate a       case unEl a of         MetaV{} -> return True@@ -412,7 +446,7 @@       k      checkCandidateForMeta :: MetaId -> Type -> Candidate -> TCM YesNoMaybe-    checkCandidateForMeta m t (Candidate term t' _) = checkDepth term t' $ do+    checkCandidateForMeta m t (Candidate q term t' _) = checkDepth term t' $ do       -- Andreas, 2015-02-07: New metas should be created with range of the       -- current instance meta, thus, we set the range.       mv <- lookupMeta m@@ -495,7 +529,7 @@           debugTypeFail err       = reportSDoc "tc.instance" 50 $ "candidate failed type check:" <+> prettyTCM err            hardFailure :: TCErr -> Bool-          hardFailure (TypeError _ err) =+          hardFailure (TypeError _ _ err) =             case clValue err of               InstanceSearchDepthExhausted{} -> True               _                              -> False@@ -519,13 +553,14 @@ nowConsideringInstance :: (ReadTCState m) => m a -> m a nowConsideringInstance = locallyTCState stConsideringInstance $ const True +isInstanceProblemConstraint :: ProblemConstraint -> Bool+isInstanceProblemConstraint = isInstanceConstraint . clValue . theConstraint+ wakeupInstanceConstraints :: TCM () wakeupInstanceConstraints =   unlessM shouldPostponeInstanceSearch $ do-    wakeConstraints (return . isInstance)-    solveSomeAwakeConstraints isInstance False-  where-    isInstance = isInstanceConstraint . clValue . theConstraint+    wakeConstraints (wakeUpWhen_ isInstanceProblemConstraint)+    solveSomeAwakeConstraints isInstanceProblemConstraint False  postponeInstanceConstraints :: TCM a -> TCM a postponeInstanceConstraints m =

src/full/Agda/TypeChecking/Irrelevance.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NondecreasingIndentation #-}  {-| Compile-time irrelevance.@@ -76,6 +75,8 @@  import Control.Arrow (second) +import Control.Monad.Except+ import qualified Data.Map as Map  import Agda.Interaction.Options@@ -90,6 +91,7 @@  import Agda.Utils.Function import Agda.Utils.Lens+import Agda.Utils.Maybe import Agda.Utils.Monad  -- | data 'Relevance'@@ -99,7 +101,7 @@  -- | Prepare parts of a parameter telescope for abstraction in constructors --   and projections.-hideAndRelParams :: Dom a -> Dom a+hideAndRelParams :: (LensHiding a, LensRelevance a) => a -> a hideAndRelParams = hideOrKeepInstance . mapRelevance nonStrictToIrr  -- * Operations on 'Context'.@@ -166,29 +168,12 @@       (applyRelevanceToContextOnly rel) $    -- enable local irr. defs only when option       applyRelevanceToJudgementOnly rel cont -- enable global irr. defs alway --- | (Conditionally) wake up erased variables and make them unrestricted.---   For instance,---   in an erased function argument otherwise erased variables---   may be used, so they are awoken before type checking the argument.------   Also allow the use of erased definitions.+-- | Sets the current quantity (unless the given quantity is 1). applyQuantityToContext :: (MonadTCEnv tcm, LensQuantity q) => q -> tcm a -> tcm a applyQuantityToContext thing =   case getQuantity thing of     Quantity1{} -> id-    q         -> applyQuantityToContextOnly   q-               . applyQuantityToJudgementOnly q---- | (Conditionally) wake up erased variables and make them unrestricted.---   For instance,---   in an erased function argument otherwise erased variables---   may be used, so they are awoken before type checking the argument.------   Precondition: @Quantity /= Quantity1@-applyQuantityToContextOnly :: (MonadTCEnv tcm) => Quantity -> tcm a -> tcm a-applyQuantityToContextOnly q = localTC-  $ over eContext     (map $ inverseApplyQuantity q)-  . over eLetBindings (Map.map . fmap . second $ inverseApplyQuantity q)+    q           -> applyQuantityToJudgementOnly q  -- | Apply quantity @q@ the the quantity annotation of the (typing/equality) --   judgement.  This is part of the work done when going into a @q@-context.@@ -201,9 +186,9 @@ applyCohesionToContext :: (MonadTCEnv tcm, LensCohesion m) => m -> tcm a -> tcm a applyCohesionToContext thing =   case getCohesion thing of-    m | m == mempty -> id-      | otherwise   -> applyCohesionToContextOnly   m-                       -- Cohesion does not apply to the judgment.+    m | m == unitCohesion -> id+      | otherwise         -> applyCohesionToContextOnly   m+                             -- Cohesion does not apply to the judgment.  applyCohesionToContextOnly :: (MonadTCEnv tcm) => Cohesion -> tcm a -> tcm a applyCohesionToContextOnly q = localTC@@ -222,23 +207,30 @@ --   may be used, so they are awoken before type checking the argument. -- --   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 =   case getModality thing of-    m | m == mempty -> id-      | otherwise   -> applyModalityToContextOnly   m-                     . applyModalityToJudgementOnly m+    m | m == unitModality -> id+      | otherwise         -> applyModalityToContextOnly   m+                           . applyModalityToJudgementOnly m  -- | (Conditionally) wake up irrelevant variables and make them relevant. --   For instance, --   in an irrelevant function argument otherwise irrelevant variables---   may be used, so they are awoken before type checking the argument.+--   may be used, so they are awoken before type checking the+--   argument. --+--   This function might also do something for other modalities, but+--   not for quantities.+-- --   Precondition: @Modality /= Relevant@ applyModalityToContextOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a applyModalityToContextOnly m = localTC-  $ over eContext     (map $ inverseApplyModality m)-  . over eLetBindings (Map.map . fmap . second $ inverseApplyModality m)+  $ over eContext (map $ inverseApplyModalityButNotQuantity m)+  . over eLetBindings+      (Map.map . fmap . second $ inverseApplyModalityButNotQuantity m)  -- | Apply modality @m@ the the modality annotation of the (typing/equality) --   judgement.  This is part of the work done when going into a @m@-context.@@ -268,10 +260,12 @@ --   This is not the right thing to do when type checking interactively in a --   hole since it also marks all metas created during type checking as --   irrelevant (issue #2568).+--+--   Also set the current quantity to 0. wakeIrrelevantVars :: (MonadTCEnv tcm) => tcm a -> tcm a wakeIrrelevantVars   = applyRelevanceToContextOnly Irrelevant-  . applyQuantityToContextOnly  zeroQuantity+  . applyQuantityToJudgementOnly zeroQuantity  -- | Check whether something can be used in a position of the given relevance. --@@ -288,10 +282,12 @@ --   (irrelevant) definitions. -- class UsableRelevance a where-  usableRel :: Relevance -> a -> TCM Bool+  usableRel+    :: (ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m)+    => Relevance -> a -> m Bool  instance UsableRelevance Term where-  usableRel rel u = case u of+  usableRel rel = \case     Var i vs -> do       irel <- getRelevance <$> domOfBV i       let ok = irel `moreRelevant` rel@@ -319,12 +315,14 @@   usableRel rel (El _ t) = usableRel rel t  instance UsableRelevance Sort where-  usableRel rel s = case s of+  usableRel rel = \case     Type l -> usableRel rel l     Prop l -> usableRel rel l-    Inf    -> return True+    Inf f n -> return True+    SSet l -> usableRel rel l     SizeUniv -> return True-    PiSort a s -> usableRel rel (a,s)+    LockUniv -> return True+    PiSort 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@@ -337,21 +335,15 @@ instance UsableRelevance PlusLevel where   usableRel rel (Plus _ l) = usableRel rel l -instance UsableRelevance LevelAtom where-  usableRel rel l = case l of-    MetaLevel m vs -> do-      mrel <- getMetaRelevance <$> lookupMeta m-      return (mrel `moreRelevant` rel) `and2M` usableRel rel vs-    NeutralLevel _ v -> usableRel rel v-    BlockedLevel _ v -> usableRel rel v-    UnreducedLevel v -> usableRel rel v- instance UsableRelevance a => UsableRelevance [a] where   usableRel rel = andM . map (usableRel rel)  instance (UsableRelevance a, UsableRelevance b) => UsableRelevance (a,b) where   usableRel rel (a,b) = usableRel rel a `and2M` usableRel rel b +instance (UsableRelevance a, UsableRelevance b, UsableRelevance c) => UsableRelevance (a,b,c) where+  usableRel rel (a,b,c) = usableRel rel a `and2M` usableRel rel b `and2M` usableRel rel c+ instance UsableRelevance a => UsableRelevance (Elim' a) where   usableRel rel (Apply a) = usableRel rel a   usableRel rel (Proj _ p) = do@@ -367,7 +359,7 @@ instance UsableRelevance a => UsableRelevance (Dom a) where   usableRel rel Dom{unDom = u} = usableRel rel u -instance (Subst t a, UsableRelevance a) => UsableRelevance (Abs a) where+instance (Subst a, UsableRelevance a) => UsableRelevance (Abs a) where   usableRel rel abs = underAbstraction_ abs $ \u -> usableRel rel u  -- | Check whether something can be used in a position of the given modality.@@ -384,10 +376,13 @@ --   definitions. -- class UsableModality a where-  usableMod :: Modality -> a -> TCM Bool+  usableMod+    :: (ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadError Blocker m)+    => Modality -> a -> m Bool  instance UsableModality Term where-  usableMod mod u = case u of+  usableMod mod u = do+   case u of     Var i vs -> do       imod <- getModality <$> domOfBV i       let ok = imod `moreUsableModality` mod@@ -406,8 +401,14 @@       return ok `and2M` usableMod mod vs     Con c _ vs -> usableMod mod vs     Lit l    -> return True-    Lam _ v  -> usableMod mod v-    Pi a b   -> usableMod mod (a,b)+    Lam info v  -> usableModAbs info mod v+    -- Even if Pi contains Type, here we check it as a constructor for terms in the universe.+    Pi a b   -> usableMod domMod (unEl $ unDom a) `and2M` usableModAbs (getArgInfo a) mod (unEl <$> b)+      where+        domMod = mapQuantity (composeQuantity $ getQuantity a) $+                 mapCohesion (composeCohesion $ getCohesion a) mod+    -- Andrea 15/10/2020 not updating these cases yet, but they are quite suspicious,+    -- do we have special typing rules for Sort and Level?     Sort s   -> usableMod mod s     Level l  -> return True     MetaV m vs -> do@@ -417,10 +418,17 @@         "Metavariable" <+> prettyTCM (MetaV m []) <+>         text ("has modality " ++ show mmod ++ ", which is a " ++               (if ok then "" else "NOT ") ++ "more usable modality than " ++ show mod)-      return ok `and2M` usableMod mod vs+      (return ok `and2M` usableMod mod vs) `or2M` do+        u <- instantiate u+        caseMaybe (isMeta u) (usableMod mod u) $ \ m -> throwError (UnblockOnMeta m)     DontCare v -> usableMod mod v     Dummy{}  -> return True +usableModAbs :: (Subst a, MonadAddContext m, UsableModality a,+                       ReadTCState m, 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+ instance UsableRelevance a => UsableModality (Type' a) where   usableMod mod (El _ t) = usableRel (getRelevance mod) t @@ -443,15 +451,6 @@ --   usableMod mod ClosedLevel{} = return True --   usableMod mod (Plus _ l)    = usableMod mod l --- instance UsableModality LevelAtom where---   usableMod mod l = case l of---     MetaLevel m vs -> do---       mmod <- getMetaModality <$> lookupMeta m---       return (mmod `moreUsableModality` mod) `and2M` usableMod mod vs---     NeutralLevel _ v -> usableMod mod v---     BlockedLevel _ v -> usableMod mod v---     UnreducedLevel v -> usableMod mod v- instance UsableModality a => UsableModality [a] where   usableMod mod = andM . map (usableMod mod) @@ -473,20 +472,69 @@ instance UsableModality a => UsableModality (Dom a) where   usableMod mod Dom{unDom = u} = usableMod mod u -instance (Subst t a, UsableModality a) => UsableModality (Abs a) where-  usableMod mod abs = underAbstraction_ abs $ \u -> usableMod mod u+usableAtModality :: MonadConstraint TCM => Modality -> Term -> TCM ()+usableAtModality mod t = catchConstraint (UsableAtModality mod t) $ do+  res <- runExceptT $ usableMod mod t+  case res of+    Right b -> do+      unless b $+        typeError . GenericDocError =<< (prettyTCM t <+> "is not usable at the required modality" <+> prettyTCM mod)+    Left blocker -> patternViolation blocker   -- * Propositions  -- | Is a type a proposition?  (Needs reduction.) -isPropM :: (LensSort a, PrettyTCM a, MonadReduce m, MonadDebug m) => a -> m Bool+isPropM+  :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)+  => a -> m Bool isPropM a = do   traceSDoc "tc.prop" 80 ("Is " <+> prettyTCM a <+> "of sort" <+> prettyTCM (getSort a) <+> "in Prop?") $ do-  reduce (getSort a) <&> \case+  abortIfBlocked (getSort a) <&> \case     Prop{} -> True     _      -> False -isIrrelevantOrPropM :: (LensRelevance a, LensSort a, PrettyTCM a, MonadReduce m, MonadDebug m) => a -> m Bool+isIrrelevantOrPropM+  :: (LensRelevance a, LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)+  => a -> m Bool isIrrelevantOrPropM x = return (isIrrelevant x) `or2M` isPropM x++-- * Fibrant types++-- | Is a type fibrant (i.e. Type, Prop)?++isFibrant+  :: (LensSort a, PureTCM m, MonadBlock m)+  => a -> m Bool+isFibrant a = abortIfBlocked (getSort a) <&> \case+  Type{}     -> True+  Prop{}     -> True+  Inf f _    -> f == IsFibrant+  SSet{}     -> False+  SizeUniv{} -> False+  LockUniv{} -> False+  PiSort{}   -> False+  FunSort{}  -> False+  UnivSort{} -> False+  MetaS{}    -> False+  DefS{}     -> False+  DummyS{}   -> False+++-- | Cofibrant types are those that could be the domain of a fibrant+--   pi type. (Notion by C. Sattler).+isCoFibrantSort :: (LensSort a, PureTCM m, MonadBlock m) => a -> m Bool+isCoFibrantSort a = abortIfBlocked (getSort a) <&> \case+  Type{}     -> True+  Prop{}     -> True+  Inf f _    -> f == IsFibrant+  SSet{}     -> False+  SizeUniv{} -> False+  LockUniv{} -> True+  PiSort{}   -> False+  FunSort{}  -> False+  UnivSort{} -> False+  MetaS{}    -> False+  DefS{}     -> False+  DummyS{}   -> False

src/full/Agda/TypeChecking/Irrelevance.hs-boot view

@@ -3,9 +3,12 @@  import Agda.Syntax.Internal (LensSort) -import Agda.TypeChecking.Monad.Base (MonadTCEnv, HasOptions, MonadReduce)+import Agda.TypeChecking.Monad.Base (MonadTCEnv, HasOptions, MonadBlock) import Agda.TypeChecking.Monad.Debug (MonadDebug) import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM)+import Agda.TypeChecking.Monad.Pure (PureTCM)  workOnTypes :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a-isPropM :: (LensSort a, PrettyTCM a, MonadReduce m, MonadDebug m) => a -> m Bool+isPropM+  :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)+  => a -> m Bool

src/full/Agda/TypeChecking/Level.hs view

@@ -4,8 +4,7 @@ import Data.Maybe import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Traversable (traverse)+import Data.Traversable (Traversable)  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -14,7 +13,6 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Monad.Builtin  import Agda.Utils.Maybe ( caseMaybeM, allJustM ) import Agda.Utils.Monad ( tryMaybe )@@ -37,7 +35,7 @@ levelType :: (HasBuiltins m) => m Type levelType = El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel -isLevelType :: (HasBuiltins m, MonadReduce m) => Type -> m Bool+isLevelType :: PureTCM m => Type -> m Bool isLevelType a = reduce (unEl a) >>= \case   Def f [] -> do     Def lvl [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel@@ -107,10 +105,10 @@   Max m as  -> foldl1 max $ [ unConstV zer suc m | m > 0 ] ++ map (unPlusV suc) as  unConstV :: Term -> (Term -> Term) -> Integer -> Term-unConstV zer suc n = foldr (.) id (List.genericReplicate n suc) zer+unConstV zer suc n = foldr ($) zer (List.genericReplicate n suc)  unPlusV :: (Term -> Term) -> PlusLevel -> Term-unPlusV suc (Plus n a) = foldr (.) id (List.genericReplicate n suc) (unLevelAtom a)+unPlusV suc (Plus n a) = foldr ($) a (List.genericReplicate n suc)  maybePrimCon :: TCM Term -> TCM (Maybe ConHead) maybePrimCon prim = tryMaybe $ do@@ -122,16 +120,14 @@     Def f [] <- prim     return f -levelView :: (HasBuiltins m, MonadReduce m, MonadDebug m)-          => Term -> m Level+levelView :: PureTCM m => Term -> m Level levelView a = do   reportSLn "tc.level.view" 50 $ "{ levelView " ++ show a   v <- levelView' a   reportSLn "tc.level.view" 50 $ "  view: " ++ show v ++ "}"   return v -levelView' :: (HasBuiltins m, MonadReduce m, MonadDebug m)-           => Term -> m Level+levelView' :: PureTCM m => Term -> m Level levelView' a = do   Def lzero [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero   Def lsuc  [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc@@ -146,18 +142,8 @@             | z == lzero -> return $ ClosedLevel 0           Def m [Apply arg1, Apply arg2]             | m == lmax  -> levelLub <$> view (unArg arg1) <*> view (unArg arg2)-          _              -> return $ mkAtom ba+          l              -> return $ atomicLevel l   view a-  where-    mkAtom ba = atomicLevel $ case ba of-        NotBlocked _ (MetaV m as) -> MetaLevel m as-        NotBlocked r _            -> case r of-          StuckOn{}               -> NeutralLevel r $ ignoreBlocking ba-          Underapplied{}          -> NeutralLevel r $ ignoreBlocking ba-          AbsurdMatch{}           -> NeutralLevel r $ ignoreBlocking ba-          MissingClauses{}        -> UnreducedLevel $ ignoreBlocking ba-          ReallyNotBlocked{}      -> NeutralLevel r $ ignoreBlocking ba-        Blocked m _               -> BlockedLevel m $ ignoreBlocking ba  -- | Given a level @l@, find the maximum constant @n@ such that @l = n + l'@ levelPlusView :: Level -> (Integer, Level)@@ -219,10 +205,14 @@  -- | A @SingleLevel@ is a @Level@ that cannot be further decomposed as --   a maximum @a ⊔ b@.-data SingleLevel = SingleClosed Integer | SinglePlus PlusLevel-  deriving (Eq, Show)+data SingleLevel' t = SingleClosed Integer | SinglePlus (PlusLevel' t)+  deriving (Show, Functor, Foldable, Traversable) -unSingleLevel :: SingleLevel -> Level+type SingleLevel = SingleLevel' Term++deriving instance Eq SingleLevel++unSingleLevel :: SingleLevel' t -> Level' t unSingleLevel (SingleClosed m) = Max m [] unSingleLevel (SinglePlus a)   = Max 0 [a] @@ -233,20 +223,22 @@     n = maximum $ 0 : [m | SingleClosed m <- ls]     as = [a | SinglePlus a <- ls] -levelMaxView :: Level -> NonEmpty SingleLevel+levelMaxView :: Level' t -> NonEmpty (SingleLevel' t) levelMaxView (Max n [])     = singleton $ SingleClosed n levelMaxView (Max 0 (a:as)) = SinglePlus a :| map SinglePlus as levelMaxView (Max n as)     = SingleClosed n :| map SinglePlus as -singleLevelView :: Level -> Maybe SingleLevel+singleLevelView :: Level' t -> Maybe (SingleLevel' t) singleLevelView l = case levelMaxView l of   s :| [] -> Just s   _       -> Nothing -instance Subst Term SingleLevel where+instance Subst t => Subst (SingleLevel' t) where+  type SubstArg (SingleLevel' t) = SubstArg t+   applySubst sub (SingleClosed m) = SingleClosed m   applySubst sub (SinglePlus a)   = SinglePlus $ applySubst sub a -instance Free SingleLevel where+instance Free t => Free (SingleLevel' t) where   freeVars' (SingleClosed m) = mempty   freeVars' (SinglePlus a)   = freeVars' a

src/full/Agda/TypeChecking/Level/Solve.hs view

@@ -3,6 +3,7 @@ module Agda.TypeChecking.Level.Solve where  import Control.Monad+import Control.Monad.Except  import qualified Data.IntSet as IntSet import Data.IntSet (IntSet)@@ -12,7 +13,6 @@  import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.MetaVars  import Agda.TypeChecking.Level import Agda.TypeChecking.MetaVars.Mention@@ -20,19 +20,19 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope -import Agda.Utils.Except+import Agda.Utils.Functor import Agda.Utils.Monad  -- | Run the given action. At the end take all new metavariables of --   type level for which the only constraints are upper bounds on the --   level, and instantiate them to the lowest level.-defaultOpenLevelsToZero :: MonadMetaSolver m => m a -> m a+defaultOpenLevelsToZero :: (PureTCM m, MonadMetaSolver m) => m a -> m a defaultOpenLevelsToZero f = ifNotM (optCumulativity <$> pragmaOptions) f $ do   (result , newMetas) <- metasCreatedBy f   defaultLevelsToZero newMetas   return result -defaultLevelsToZero :: forall m. (MonadMetaSolver m) => IntSet -> m ()+defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => IntSet -> m () defaultLevelsToZero xs = loop =<< openLevelMetas (map MetaId $ IntSet.elems xs)   where     loop :: [MetaId] -> m ()@@ -51,13 +51,11 @@              `catchError` \_ -> return False            | otherwise -> return False -      if | or progress -> loop xs-         | otherwise   -> return ()+      when (or progress) $ (loop xs)      openLevelMetas :: [MetaId] -> m [MetaId]-    openLevelMetas xs = return xs-      >>= filterM (\m -> isNothing <$> isInteractionMeta m)-      >>= filterM (\m -> (== NoGeneralize) <$> isGeneralizableMeta m)+    openLevelMetas xs = filterM (isNothing <.> isInteractionMeta) xs+      >>= filterM (fmap (== NoGeneralize) . isGeneralizableMeta)       >>= filterM isLevelMeta      isLevelMeta :: MetaId -> m Bool

src/full/Agda/TypeChecking/LevelConstraints.hs view

@@ -2,8 +2,6 @@ module Agda.TypeChecking.LevelConstraints ( simplifyLevelConstraint ) where  import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base@@ -13,6 +11,7 @@  import Agda.Utils.Impossible import Agda.Utils.List (nubOn)+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Update  -- | @simplifyLevelConstraint c cs@ turns an @c@ into an equality@@ -59,7 +58,7 @@         go _ [] = IdS         go y ren0@((y', x) : ren)           | y == y'   = Var x [] :# go (y + 1) ren-          | otherwise = Strengthen __IMPOSSIBLE__ $ go (y + 1) ren0+          | otherwise = Strengthen impossible $ go (y + 1) ren0  -- | Turn a level constraint into a list of inequalities between --   single levels, if possible.@@ -67,7 +66,7 @@ inequalities :: Constraint -> Maybe [Leq]  inequalities (LevelCmp CmpLeq a b)-  | Just b' <- singleLevelView b = Just $ map (:=< b') $ NonEmpty.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!@@ -77,13 +76,13 @@  inequalities (LevelCmp CmpEq a b)   | Just a' <- singleLevelView a =-  case break (== a') (NonEmpty.toList $ levelMaxView b) of+  case List1.break (== a') (levelMaxView b) of     (bs0, _ : bs1) -> Just [ b' :=< a' | b' <- bs0 ++ bs1 ]     _              -> Nothing  inequalities (LevelCmp CmpEq a b)   | Just b' <- singleLevelView b =-  case break (== b') (NonEmpty.toList $ levelMaxView a) of+  case List1.break (== b') (levelMaxView a) of     (as0, _ : as1) -> Just [ a' :=< b' | a' <- as0 ++ as1 ]     _              -> Nothing inequalities _ = Nothing

+ src/full/Agda/TypeChecking/Lock.hs view

@@ -0,0 +1,134 @@+{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Lock+  ( isTimeless+  , checkLockedVars+  , checkEarlierThan+  , requireGuarded+  )+where++import Control.Monad.Reader++--import qualified Data.IntMap as IMap+import qualified Data.IntSet as ISet+++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.Interaction.Options ( optGuarded )++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute.Class+import Agda.TypeChecking.Free++import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Size+import Agda.Utils.VarSet as Set++import Agda.Utils.Impossible++requireGuarded :: String -> TCM ()+requireGuarded s = do+  guarded <- optGuarded <$> pragmaOptions+  unless guarded $+    typeError $ GenericError $ "Missing option --guarded " ++ s+++checkLockedVars+  :: Term+     -- ^ term to check+  -> Type+     -- ^ its type+  -> Arg Term+     -- ^ the lock+  -> Type+     -- ^ type of the lock+  -> TCM ()+checkLockedVars t ty lk lk_ty = catchConstraint (CheckLockedVars t ty lk lk_ty) $ do+  reportSDoc "tc.term.lock" 40 $ "Checking locked vars.."+  reportSDoc "tc.term.lock" 50 $ nest 2 $ vcat+     [ text "t     = " <+> pretty t+     , text "ty    = " <+> pretty ty+     , text "lk    = " <+> pretty lk+     , text "lk_ty = " <+> pretty lk_ty+     ]++  -- Strategy: compute allowed variables, check that @t@ doesn't use more.+  mv <- isVar (unArg lk)+  caseMaybe mv noVar $ \ i -> do++  isLock i++  cxt <- getContext+  let toCheck = zip [0..] $ zipWith raise [1..] (take i cxt)++  let fv = freeVarsIgnore IgnoreInAnnotations (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++  checked <- fmap catMaybes . forM toCheck $ \ (j,dom) -> do+    ifM (isTimeless (snd . unDom $ dom))+        (return $ Just j)+        (return $ Nothing)++  let allowedVars = ISet.union earlierVars (ISet.fromList checked)++  if termVars `ISet.isSubsetOf` allowedVars then return () else do+  let+    illegalVars = rigid ISet.\\ allowedVars+    -- flexVars = flexibleVars fv+    -- blockingMetas = map (`lookupVarMap` flexVars) (ISet.toList $ termVars ISet.\\ allowedVars)+  if ISet.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 do+    notAllowedVarsError (unArg lk) (ISet.toList illegalVars)+ where+   noVar = typeError $ GenericError "lock should be a var"+   isLock i = do+     islock <- getLock . domInfo <$> lookupBV i+     unless (islock == IsLock) $+       typeError $ GenericError "Cannot eliminate with non-lock variable."++-- to use only on lock terms+isVar :: Term -> TCMT IO (Maybe Int)+isVar t = do+  t <- abortIfBlocked t+  case t of+    (Var l []) -> return $ Just l+    _          -> return $ Nothing++isTimeless :: Type -> TCM Bool+isTimeless t = do+  t <- abortIfBlocked t+  timeless <- mapM getName' [builtinInterval, builtinIsOne]+  case unEl t of+    Def q _ | Just q `elem` timeless -> return True+    _                                -> return False++notAllowedVarsError :: Term -> [Int] -> TCM b+notAllowedVarsError lk is = do+        typeError . GenericDocError =<<+         ("The following vars are not allowed in a later value applied to"+          <+> prettyTCM lk <+> ":" <+> prettyTCM (map var $ is))++checkEarlierThan :: Term -> VarSet -> TCM ()+checkEarlierThan lk fvs = do+  mv <- isVar lk+  caseMaybe mv __IMPOSSIBLE__ $ \ i -> do+    let problems = filter (<= i) $ Set.toList fvs+    forM_ problems $ \ j -> do+      ty <- typeOfBV j+      unlessM (isTimeless ty) $+        notAllowedVarsError lk [j]

+ src/full/Agda/TypeChecking/Lock.hs-boot view

@@ -0,0 +1,35 @@+{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Lock where++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad.Base+-- import Agda.TypeChecking.Monad.Context+-- import Agda.TypeChecking.Pretty+-- import Agda.TypeChecking.Reduce+-- import Agda.TypeChecking.Substitute.Class+-- import Agda.TypeChecking.Telescope+-- import Agda.TypeChecking.Free++-- import Agda.Utils.Function+-- import Agda.Utils.Lens+-- import Agda.Utils.Maybe+-- import Agda.Utils.Monad+-- import Agda.Utils.Size++-- #include "undefined.h"+-- import Agda.Utils.Impossible++++checkLockedVars+  :: Term+     -- ^ term to check+  -> Type+     -- ^ its type+  -> Arg Term+     -- ^ the lock+  -> Type+     -- ^ type of the lock+  -> TCM ()

src/full/Agda/TypeChecking/MetaVars.hs view

@@ -5,10 +5,12 @@  import Prelude hiding (null) +import Control.Monad.Except import Control.Monad.Reader  import Data.Function import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet import qualified Data.List as List import qualified Data.Set as Set import qualified Data.Foldable as Fold@@ -24,7 +26,8 @@ import Agda.Syntax.Position (getRange, killRange)  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin+-- import Agda.TypeChecking.Monad.Builtin+-- import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Reduce import Agda.TypeChecking.Sort import Agda.TypeChecking.Substitute@@ -32,7 +35,7 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Constraints import Agda.TypeChecking.Free-import Agda.TypeChecking.Free.Lazy+import Agda.TypeChecking.Lock import Agda.TypeChecking.Level (levelType) import Agda.TypeChecking.Records import Agda.TypeChecking.Pretty@@ -46,11 +49,6 @@ -- import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (checkInternal) import Agda.TypeChecking.MetaVars.Occurs -import Agda.Utils.Except-  ( ExceptT-  , MonadError(throwError, catchError)-  , runExceptT-  ) import Agda.Utils.Function import Agda.Utils.Lens import Agda.Utils.List@@ -89,8 +87,13 @@ --   @reverse@ is necessary because we are directly abstracting over the list. -- findIdx :: Eq a => [a] -> a -> Maybe Int-findIdx vs v = List.findIndex (==v) (reverse vs)+findIdx vs v = List.elemIndex v (reverse vs) +hasTwinMeta :: MetaId -> TCM Bool+hasTwinMeta x = do+    m <- lookupMeta x+    return $ isJust $ mvTwin m+ -- | Check whether a meta variable is a place holder for a blocked term. isBlockedTerm :: MetaId -> TCM Bool isBlockedTerm x = do@@ -111,7 +114,7 @@     i <- mvInstantiation <$> lookupMeta x     return $ case i of       Open{}                         -> True-      OpenInstance{}                 -> notElem Records kinds+      OpenInstance{}                 -> Records `notElem` kinds       InstV{}                        -> False       BlockedConst{}                 -> False       PostponedTypeCheckingProblem{} -> False@@ -197,8 +200,7 @@   (x, v) <- newValueMeta RunMetaOccursCheck CmpEq =<< levelType   return $ case v of     Level l    -> l-    MetaV x vs -> Max 0 [Plus 0 (MetaLevel x vs)]-    _          -> Max 0 [Plus 0 (UnreducedLevel v)]+    _          -> atomicLevel v  -- | @newInstanceMeta s t cands@ creates a new instance metavariable --   of type the output type of @t@ with name suggestion @s@.@@ -227,11 +229,11 @@   reportSDoc "tc.meta.new" 50 $ fsep     [ nest 2 $ pretty x <+> ":" <+> prettyTCM t     ]-  let c = FindInstance x Nothing Nothing+  let c = FindInstance x Nothing   -- If we're not already solving instance constraints we should add this   -- to the awake constraints to make sure we don't forget about it. If we   -- are solving constraints it will get woken up later (see #2690)-  ifM isSolvingConstraints (addConstraint c) (addAwakeConstraint c)+  ifM isSolvingConstraints (addConstraint alwaysUnblock c) (addAwakeConstraint alwaysUnblock c)   etaExpandMetaSafe x   return (x, MetaV x $ map Apply vs) @@ -278,10 +280,11 @@   i <- createMetaInfo' b   let t     = telePi_ tel a   x <- newMeta frozen i normalMetaPriority perm (HasType () cmp t)+  modality <- viewTC eModality   reportSDoc "tc.meta.new" 50 $ fsep     [ text $ "new meta (" ++ show (i ^. lensIsAbstract) ++ "):"     , nest 2 $ prettyTCM vs <+> "|-"-    , nest 2 $ pretty x <+> ":" <+> prettyTCM t+    , nest 2 $ pretty x <+> ":" <+> pretty modality <+> prettyTCM t     ]   etaExpandMetaSafe x   -- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u@@ -319,11 +322,18 @@       let mod  = getModality info           -- 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 `inverseApplyModality`) . telToList $ tel-          ctx' = (map . mapModality) (mod `inverseComposeModality`) ctx+          tel' = telFromList $+                 map (mod `inverseApplyModalityButNotQuantity`) $+                 telToList tel+          ctx' = map (mod `inverseApplyModalityButNotQuantity`) ctx       (m, u) <- applyModalityToContext info $                  newValueMetaCtx frozen RunMetaOccursCheck CmpLeq a tel' perm ctx'-      setMetaArgInfo m (getArgInfo dom)+      -- 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).+      whenM ((== YesGeneralizeVar) <$> viewTC eGeneralizeMetas) $+        setMetaGeneralizableArgInfo m $ hideOrKeepInstance info       setMetaNameSuggestion m (absName codom)       args <- newArgsMetaCtx' frozen condition (codom `absApp` u) tel perm ctx       return $ Arg info u : args@@ -381,35 +391,47 @@ blockTermOnProblem   :: (MonadMetaSolver m, MonadFresh Nat m)   => Type -> Term -> ProblemId -> m Term-blockTermOnProblem t v pid =+blockTermOnProblem t v pid = do   -- Andreas, 2012-09-27 do not block on unsolved size constraints-  ifM (isProblemSolved pid `or2M` isSizeProblem pid) (return v) $ do+  solved <- isProblemSolved pid+  ifM (return solved `or2M` isSizeProblem pid)+      (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     tel <- getContextTelescope     x   <- newMeta' (BlockedConst $ abstract tel v)-                    Instantiable i lowMetaPriority (idP $ size tel)+                    Instantiable+                    i+                    lowMetaPriority+                    (idP $ size tel)                     (HasType () CmpLeq $ telePi_ tel t)                     -- we don't instantiate blocked terms-    inTopContext $ addConstraint (Guarded (UnBlock x) pid)+    inTopContext $ addConstraint (unblockOnProblem pid) (UnBlock x)     reportSDoc "tc.meta.blocked" 20 $ vcat-      [ "blocked" <+> prettyTCM x <+> ":=" <+> inTopContext (prettyTCM $ abstract tel v)-      , "     by" <+> (prettyTCM =<< getConstraintsForProblem pid) ]+      [ "blocked" <+> prettyTCM x <+> ":=" <+> inTopContext+        (prettyTCM $ abstract tel v)+      , "     by" <+> (prettyTCM =<< getConstraintsForProblem pid)+      ]     inst <- isInstantiatedMeta x-    case inst of-      True  -> instantiate (MetaV x es)-      False -> do+    if inst+      then instantiate (MetaV x es)+      else do         -- We don't return the blocked term instead create a fresh metavariable         -- that we compare against the blocked term once it's unblocked. This way         -- blocked terms can be instantiated before they are unblocked, thus making         -- constraint solving a bit more robust against instantiation order.         -- Andreas, 2015-05-22: DontRunMetaOccursCheck to avoid Issue585-17.         (m', v) <- newValueMeta DontRunMetaOccursCheck CmpLeq t-        reportSDoc "tc.meta.blocked" 30 $ "setting twin of" <+> prettyTCM m' <+> "to be" <+> prettyTCM x-        updateMetaVar m' (\ mv -> mv { mvTwin = Just x })+        reportSDoc "tc.meta.blocked" 30+          $   "setting twin of"+          <+> prettyTCM m'+          <+> "to be"+          <+> prettyTCM x+        updateMetaVar m' (\mv -> mv { mvTwin = Just x })         i   <- fresh         -- This constraint is woken up when unblocking, so it doesn't need a problem id.-        cmp <- buildProblemConstraint_ (ValueCmp CmpEq (AsTermsOf t) v (MetaV x es))+        cmp <- buildProblemConstraint_ (unblockOnMeta x) (ValueCmp CmpEq (AsTermsOf t) v (MetaV x es))         reportSDoc "tc.constr.add" 20 $ "adding constraint" <+> prettyTCM cmp         listenToMeta (CheckConstraint i cmp) x         return v@@ -417,23 +439,23 @@ blockTypeOnProblem   :: (MonadMetaSolver m, MonadFresh Nat m)   => Type -> ProblemId -> m Type-blockTypeOnProblem (El s a) pid = El s <$> blockTermOnProblem (El Inf $ Sort s) a pid+blockTypeOnProblem (El s a) pid = El s <$> blockTermOnProblem (sort s) a pid --- | @unblockedTester t@ returns @False@ if @t@ is a meta or a blocked term.+-- | @unblockedTester t@ returns a 'Blocker' for @t@. -----   Auxiliary function to create a postponed type checking problem.-unblockedTester :: Type -> TCM Bool-unblockedTester t = ifBlocked t (\ m t -> return False) (\ _ t -> return True)+--   Auxiliary function used when creating a postponed type checking problem.+unblockedTester :: Type -> TCM Blocker+unblockedTester t = ifBlocked t (\ b _ -> return b) (\ _ _ -> return alwaysUnblock)  -- | Create a postponed type checking problem @e : t@ that waits for type @t@ --   to unblock (become instantiated or its constraints resolved). postponeTypeCheckingProblem_ :: TypeCheckingProblem -> TCM Term postponeTypeCheckingProblem_ p = do-  postponeTypeCheckingProblem p (unblock p)+  postponeTypeCheckingProblem p =<< unblock p   where     unblock (CheckExpr _ _ t)         = unblockedTester t-    unblock (CheckArgs _ _ _ t _ _)   = unblockedTester t  -- The type of the head of the application.-    unblock (CheckProjAppToKnownPrincipalArg _ _ _ _ _ _ _ _ t) = unblockedTester t -- The type of the principal argument+    unblock (CheckArgs _ _ _ _ t _ _) = unblockedTester t  -- The type of the head of the application.+    unblock (CheckProjAppToKnownPrincipalArg _ _ _ _ _ _ _ _ t _) = unblockedTester t -- The type of the principal argument     unblock (CheckLambda _ _ _ t)     = unblockedTester t     unblock (DoQuoteTerm _ _ _)       = __IMPOSSIBLE__     -- also quoteTerm problems @@ -441,13 +463,16 @@ --   @unblock@.  A new meta is created in the current context that has as --   instantiation the postponed type checking problem.  An 'UnBlock' constraint --   is added for this meta, which links to this meta.-postponeTypeCheckingProblem :: TypeCheckingProblem -> TCM Bool -> TCM Term+postponeTypeCheckingProblem :: TypeCheckingProblem -> Blocker -> TCM Term+postponeTypeCheckingProblem p unblock | unblock == alwaysUnblock = do+  reportSDoc "impossible" 2 $ "Postponed without blocker:" <?> prettyTCM p+  __IMPOSSIBLE__ postponeTypeCheckingProblem p unblock = do   i   <- createMetaInfo' DontRunMetaOccursCheck   tel <- getContextTelescope   cl  <- buildClosure p   let t = problemType p-  m   <- newMeta' (PostponedTypeCheckingProblem cl unblock)+  m   <- newMeta' (PostponedTypeCheckingProblem cl)                   Instantiable i normalMetaPriority (idP (size tel))          $ HasType () CmpLeq $ telePi_ tel t   inTopContext $ reportSDoc "tc.meta.postponed" 20 $ vcat@@ -464,18 +489,18 @@   -- non-terminating solutions.   es  <- map Apply <$> getContextArgs   (_, v) <- newValueMeta DontRunMetaOccursCheck CmpLeq t-  cmp <- buildProblemConstraint_ (ValueCmp CmpEq (AsTermsOf t) v (MetaV m es))+  cmp <- buildProblemConstraint_ (unblockOnMeta m) (ValueCmp CmpEq (AsTermsOf t) v (MetaV m es))   reportSDoc "tc.constr.add" 20 $ "adding constraint" <+> prettyTCM cmp   i   <- liftTCM fresh   listenToMeta (CheckConstraint i cmp) m-  addConstraint (UnBlock m)+  addConstraint unblock (UnBlock m)   return v  -- | Type of the term that is produced by solving the 'TypeCheckingProblem'. problemType :: TypeCheckingProblem -> Type problemType (CheckExpr _ _ t         ) = t-problemType (CheckArgs _ _ _ _ t _ )   = t  -- The target type of the application.-problemType (CheckProjAppToKnownPrincipalArg _ _ _ _ _ t _ _ _) = t -- The target type of the application+problemType (CheckArgs _ _ _ _ _ t _ ) = t  -- The target type of the application.+problemType (CheckProjAppToKnownPrincipalArg _ _ _ _ _ t _ _ _ _) = t -- The target type of the application problemType (CheckLambda _ _ _ t     ) = t problemType (DoQuoteTerm _ _ t)        = t @@ -504,12 +529,12 @@ etaExpandMetaTCM :: [MetaKind] -> MetaId -> TCM () etaExpandMetaTCM kinds m = whenM ((not <$> isFrozen m) `and2M` asksTC envAssignMetas `and2M` isEtaExpandable kinds m) $ do   verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do-    let waitFor x = do+    let waitFor b = do           reportSDoc "tc.meta.eta" 20 $ do             "postponing eta-expansion of meta variable" <+>               prettyTCM m <+>-              "which is blocked by" <+> prettyTCM x-          listenToMeta (EtaExpand m) x+              "which is blocked by" <+> prettyTCM b+          mapM_ (listenToMeta (EtaExpand m)) $ Set.toList $ allBlockingMetas b         dontExpand = do           reportSDoc "tc.meta.eta" 20 $ do             "we do not expand meta variable" <+> prettyTCM m <+>@@ -569,12 +594,9 @@                       noConstraints $ assignTerm' m (telToArgs tel) u  -- should never produce any constraints               if Records `elem` kinds then                 expand-               else if (SingletonRecords `elem` kinds) then do-                 singleton <- isSingletonRecord r ps-                 case singleton of-                   Left x      -> waitFor x-                   Right False -> dontExpand-                   Right True  -> expand+               else if (SingletonRecords `elem` kinds) then+                catchPatternErr (\x -> waitFor x) $ do+                 ifM (isSingletonRecord r ps) expand dontExpand                 else dontExpand             ) $ {- else -} ifM (andM [ return $ Levels `elem` kinds                             , typeInType@@ -590,14 +612,16 @@ -- | Eta expand blocking metavariables of record type, and reduce the -- blocked thing. -etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, Reduce t)+etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, IsMeta t, Reduce t)                  => Blocked t -> m (Blocked t) etaExpandBlocked t@NotBlocked{} = return t-etaExpandBlocked (Blocked m t)  = do-  etaExpandMeta [Records] m+etaExpandBlocked t@(Blocked _ v) | Just{} <- isMeta v = return t+etaExpandBlocked (Blocked b t)  = do+  reportSDoc "tc.meta.eta" 30 $ "Eta expanding blockers" <+> pretty b+  mapM_ (etaExpandMeta [Records]) $ Set.toList $ allBlockingMetas b   t <- reduceB t   case t of-    Blocked m' _ | m /= m' -> etaExpandBlocked t+    Blocked b' _ | b /= b' -> etaExpandBlocked t     _                      -> return t  assignWrapper :: (MonadMetaSolver m, MonadConstraint m, MonadError TCErr m, MonadDebug m, HasOptions m)@@ -610,7 +634,7 @@    where dontAssign = do           reportSLn "tc.meta.assign" 10 "don't assign metas"-          patternViolation+          patternViolation alwaysUnblock  -- retry again when we are allowed to instantiate metas  -- | Miller pattern unification: --@@ -629,7 +653,7 @@ --   Andreas Abel and Brigitte Pientka's TLCA 2011 paper.  assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM ()-assign dir x args v target = do+assign dir x args v target = addOrUnblocker (unblockOnMeta x) $ do    mvar <- lookupMeta x  -- information associated with meta x   let t = jMetaType $ mvJudgement mvar@@ -647,7 +671,11 @@   -- with full unfolding.   v <- instantiate v   reportSDoc "tc.meta.assign" 45 $-    "MetaVars.assign: assigning to " <+> prettyTCM v+    "MetaVars.assign: assigning meta " <+> prettyTCM (MetaV x []) <+>+    " with args " <+> prettyList_ (map (prettyTCM . unArg) args) <+>+    " to " <+> prettyTCM v+  reportSDoc "tc.meta.assign" 45 $+    "MetaVars.assign: type of meta: " <+> prettyTCM t    reportSLn "tc.meta.assign" 75 $     "MetaVars.assign: assigning meta  " ++ show x ++ "  with args  " ++ show args ++ "  to  " ++ show v@@ -656,15 +684,70 @@       (Sort s, HasType{}) -> hasBiggerSort s       _                   -> return () +  -- 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.+  -- Jesper, 2020-04-22: We do this before any of the other steps+  -- because comparing the sorts might lead to some metavariables+  -- being solved, which can help with pruning (see #4615).+  -- Jesper, 2020-08-25: --no-sort-comparison is now the default+  -- behaviour.+  --+  -- Under most circumstances, the conversion checker guarantees that+  -- the solution for the meta has the correct type, so there is no+  -- need to check anything. However, there are two circumstances in+  -- which we do need to check the type of the solution:+  --+  -- 1. When comparing two types they are not guaranteed to have the+  --    same sort.+  --+  -- 2. When --cumulativity is enabled the same can happen when+  --    comparing two terms at a sort type.++  cumulativity <- optCumulativity <$> pragmaOptions++  let checkSolutionSort cmp s v = do+        s' <- sortOf v+        reportSDoc "tc.meta.assign" 40 $+          "Instantiating sort" <+> prettyTCM s <+>+          "to sort" <+> prettyTCM s' <+> "of solution" <+> prettyTCM v+        traceCall (CheckMetaSolution (getRange mvar) x (sort s) v) $+          compareSort cmp s' s++  case (target , mvJudgement mvar) of+    -- Case 1 (comparing term to meta as types)+    (AsTypes{}   , HasType _ cmp0 t) -> do+        let cmp   = if cumulativity then cmp0 else CmpEq+            abort = patternViolation $ unblockOnAnyMetaIn t -- TODO: make piApplyM' compute unblocker+        t' <- piApplyM' abort t args+        s <- shouldBeSort t'+        checkSolutionSort cmp s v++    -- Case 2 (comparing term to type-level meta as terms, with --cumulativity)+    (AsTermsOf{} , HasType _ cmp t)+      | cumulativity -> do+          let abort = patternViolation $ unblockOnAnyMetaIn t+          t' <- piApplyM' abort t args+          TelV tel t'' <- telView t'+          addContext tel $ ifNotSort t'' (return ()) $ \s -> do+            let v' = raise (size tel) v `apply` teleArgs tel+            checkSolutionSort cmp s v'++    (AsTypes{}   , IsSort{}       ) -> return ()+    (AsTermsOf{} , _              ) -> return ()+    (AsSizes{}   , _              ) -> return ()  -- TODO: should we do something similar for sizes?+++   -- We don't instantiate frozen mvars   when (mvFrozen mvar == Frozen) $ do     reportSLn "tc.meta.assign" 25 $ "aborting: meta is frozen!"-    patternViolation+    patternViolation neverUnblock    -- 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!"-    patternViolation+    patternViolation (unblockOnMeta x)    -- Andreas, 2010-10-15 I want to see whether rhs is blocked   reportSLn "tc.meta.assign" 50 $ "MetaVars.assign: I want to see whether rhs is blocked"@@ -679,13 +762,6 @@   -- @_Y args >= u@.   subtypingForSizeLt dir x mvar t args v $ \ v -> do -    -- Normalise and eta contract the arguments to the meta. These are-    -- usually small, and simplifying might let us instantiate more metas.--    -- MOVED TO expandProjectedVars:-    -- args <- etaContract =<< normalise args--    -- Also, try to expand away projected vars in meta args.     reportSDoc "tc.meta.assign.proj" 45 $ do       cxt <- getContextTelescope       vcat@@ -693,6 +769,10 @@         , nest 2 $ inTopContext $ prettyTCM cxt         ] +    -- Normalise and eta contract the arguments to the meta. These are+    -- usually small, and simplifying might let us instantiate more metas.+    -- Also, try to expand away projected vars in meta args.+     expandProjectedVars args (v, target) $ \ args (v, target) -> do        reportSDoc "tc.meta.assign.proj" 45 $ do@@ -801,11 +881,14 @@         case res of           -- all args are variables           Right ids -> do+            reportSDoc "tc.meta.assign" 60 $+              "inverseSubst returns:" <+> sep (map pretty ids)             reportSDoc "tc.meta.assign" 50 $               "inverseSubst returns:" <+> sep (map prettyTCM ids)             let boundVars = VarSet.fromList $ map fst ids-            if | fvs `VarSet.isSubsetOf` boundVars -> return $ Just ids-               | otherwise                         -> return Nothing+            if fvs `VarSet.isSubsetOf` boundVars+              then return $ Just ids+              else return Nothing           -- we have proper values as arguments which could be cased on           -- here, we cannot prune, since offending vars could be eliminated           Left CantInvert  -> return Nothing@@ -813,10 +896,10 @@           Left NeutralArg  -> Just <$> attemptPruning x args fvs           -- we have a projected variable which could not be eta-expanded away:           -- same as neutral-          Left ProjectedVar{} -> Just <$> attemptPruning x args fvs+          Left ProjVar{}   -> Just <$> attemptPruning x args fvs -      case mids of-        Nothing  -> patternViolation -- Ulf 2014-07-13: actually not needed after all: attemptInertRHSImprovement x args v+      case mids of  -- vv Ulf 2014-07-13: actually not needed after all: attemptInertRHSImprovement x args v+        Nothing  -> patternViolation (unblockOnAnyMetaIn v)  -- TODO: more precise         Just ids -> do           -- Check linearity           ids <- do@@ -825,8 +908,27 @@               -- case: linear               Right ids -> return ids               -- case: non-linear variables that could possibly be pruned-              Left ()   -> attemptPruning x args fvs+              -- If pruning fails we need to unblock on any meta in the rhs, since they might get+              -- rid of the dependency on the non-linear variable. TODO: be more precise (all metas+              -- using non-linear variables need to be solved).+              Left ()   -> addOrUnblocker (unblockOnAnyMetaIn v) $ attemptPruning x args fvs +          -- Check ids is time respecting.+          () <- do+            let idvars = map (mapSnd allFreeVars) ids+            -- earlierThan α v := v "arrives" before α+            let earlierThan l j = j > l+            TelV tel' _ <- telViewUpToPath (length args) t+            forM_ ids $ \(i,u) -> do+              d <- lookupBV i+              when (getLock (getArgInfo d) == IsLock) $ do+                let us = IntSet.unions $ map snd $ filter (earlierThan i . fst) idvars+                -- us Earlier than u+                addContext tel' $ checkEarlierThan u us+                  `catchError` \case+                     TypeError{} -> patternViolation (unblockOnMeta x) -- If the earlier check hard-fails we need to+                     err         -> throwError err                     -- solve this meta in some other way.+           let n = length args           TelV tel' _ <- telViewUpToPath n t @@ -849,28 +951,29 @@             a' <- typeOfBV i             checkSubtypeIsEqual a' a               `catchError` \case-                TypeError{} -> patternViolation-                err         -> throwError err+                TypeError{} -> patternViolation (unblockOnMeta x) -- If the subtype check hard-fails we need to+                err         -> throwError err                     -- solve this meta in some other way.            -- Solve.           m <- getContextSize           assignMeta' m x t n ids v   where-    -- | Try to remove meta arguments from lhs that mention variables not occurring on rhs.+    -- Try to remove meta arguments from lhs that mention variables not occurring on rhs.     attemptPruning-      :: MetaId  -- ^ Meta-variable (lhs)-      -> Args    -- ^ Meta arguments (lhs)-      -> FVs     -- ^ Variables occuring on the rhs+      :: MetaId  -- Meta-variable (lhs)+      -> Args    -- Meta arguments (lhs)+      -> FVs     -- Variables occuring on the rhs       -> TCM a     attemptPruning x args fvs = do       -- non-linear lhs: we cannot solve, but prune       killResult <- prune x args $ (`VarSet.member` fvs)+      let success = killResult `elem` [PrunedSomething,PrunedEverything]       reportSDoc "tc.meta.assign" 10 $-        "pruning" <+> prettyTCM x <+> do-        text $-          if killResult `elem` [PrunedSomething,PrunedEverything] then "succeeded"-           else "failed"-      patternViolation+        "pruning" <+> prettyTCM x <+> do text $ if success then "succeeded" else "failed"+      patternViolation (if success then alwaysUnblock  -- If pruning succeeded we want to retry right away+                                   else unblockOnAnyMetaIn $ MetaV x $ map Apply args)+                                        -- TODO: could be more precise: only unblock on metas+                                        --       applied to offending variables  {- UNUSED -- | When faced with @_X us == D vs@ for an inert D we can solve this by@@ -968,9 +1071,9 @@             Level{}    -> return ()             Lit{}      -> notNeutral v             DontCare{} -> notNeutral v-            MetaV{}    -> notNeutral v             Con{}      -> notNeutral v             Lam{}      -> notNeutral v+            MetaV{}    -> __IMPOSSIBLE__ -- END UNUSED -}  -- | @assignMeta m x t ids u@ solves @x ids = u@ for meta @x@ of type @t@,@@ -1005,12 +1108,12 @@   -- ALT 1: O(m * size ids), serves as specification   -- let ivs = [fromMaybe __IMPOSSIBLE__ $ lookup i ids | i <- [0..m-1]]   -- ALT 2: O(m)-  let assocToList i l = case l of+  let assocToList i = \case         _           | i >= m -> []         ((j,u) : l) | i == j -> Just u  : assocToList (i+1) l-        _                    -> Nothing : assocToList (i+1) l+        l                    -> Nothing : assocToList (i+1) l       ivs = assocToList 0 ids-      rho = prependS __IMPOSSIBLE__ ivs $ raiseS n+      rho = prependS impossible ivs $ raiseS n       v'  = applySubst rho v    -- Metas are top-level so we do the assignment at top-level.@@ -1021,33 +1124,16 @@     -- any more)     reportSDoc "tc.meta.assign" 15 $ "type of meta =" <+> prettyTCM t -    (telv@(TelV tel' a),bs) <- telViewUpToPathBoundary n t+    (telv@(TelV tel' a), bs) <- telViewUpToPathBoundary n t     reportSDoc "tc.meta.assign" 30 $ "tel'  =" <+> prettyTCM tel'     reportSDoc "tc.meta.assign" 30 $ "#args =" <+> text (show n)     -- 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)-       patternViolation -- WAS: __IMPOSSIBLE__--    -- 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.-    whenM ((not . optCompareSorts <$> pragmaOptions) `or2M`-           (optCumulativity <$> pragmaOptions)) $ case unEl a of-      Sort s -> addContext tel' $ do-        m <- lookupMeta x-        cmp <- ifM (not . optCumulativity <$> pragmaOptions) (return CmpEq) $-          case mvJudgement m of-            HasType{ jComparison = cmp } -> return cmp-            IsSort{} -> __IMPOSSIBLE__-        s' <- sortOf v'-        reportSDoc "tc.meta.assign" 40 $-          "Instantiating sort" <+> prettyTCM s <+>-          "to sort" <+> prettyTCM s' <+> "of solution" <+> prettyTCM v'-        traceCall (CheckMetaSolution (getRange m) x a v') $-          compareSort cmp s' s-      _ -> return ()+    when (size tel' < 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). @@ -1083,7 +1169,7 @@ checkMetaInst :: MetaId -> TCM () checkMetaInst x = do   m <- lookupMeta x-  let postpone = addConstraint $ CheckMetaInst x+  let postpone = addConstraint (unblockOnMeta x) $ CheckMetaInst x   case mvInstantiation m of     BlockedConst{} -> postpone     PostponedTypeCheckingProblem{} -> postpone@@ -1113,7 +1199,7 @@       reportSDoc "tc.meta.check" 30 $ nest 2 $         prettyTCM x <+> ":=" <+> prettyTCM v <+> " is a sort"       s <- shouldBeSort (El __DUMMY_SORT__ v)-      traceCall (CheckMetaSolution (getRange m) x (sort (univSort Nothing s)) (Sort s)) $+      traceCall (CheckMetaSolution (getRange m) x (sort (univSort s)) (Sort s)) $         checkSort defaultAction s  -- | Given two types @a@ and @b@ with @a <: b@, check that @a == b@.@@ -1125,29 +1211,26 @@   ((a, b), equal) <- SynEq.checkSyntacticEquality a b   unless equal $ do     cumulativity <- optCumulativity <$> pragmaOptions-    reduce (unEl b) >>= \case-      Sort sb -> reduce (unEl a) >>= \case+    abortIfBlocked (unEl b) >>= \case+      Sort sb -> abortIfBlocked (unEl a) >>= \case         Sort sa | cumulativity -> equalSort sa sb-                | otherwise    -> return ()-        MetaV{} -> patternViolation+                             | otherwise    -> return ()         Dummy{} -> return () -- TODO: this shouldn't happen but                              -- currently does because of generalized                              -- metas being created in a dummy context-        _ -> patternViolation-      Pi b1 b2 -> reduce (unEl a) >>= \case+        a -> patternViolation (unblockOnAnyMetaIn a) -- TODO: can this happen?+      Pi b1 b2 -> abortIfBlocked (unEl a) >>= \case         Pi a1 a2-          | getRelevance a1 /= getRelevance b1 -> patternViolation-          | getQuantity  a1 /= getQuantity  b1 -> patternViolation-          | getCohesion  a1 /= getCohesion  b1 -> patternViolation+          | getRelevance a1 /= getRelevance b1 -> patternViolation neverUnblock -- Can we recover from this?+          | getQuantity  a1 /= getQuantity  b1 -> patternViolation neverUnblock+          | getCohesion  a1 /= getCohesion  b1 -> patternViolation neverUnblock           | otherwise -> do               checkSubtypeIsEqual (unDom b1) (unDom a1)               underAbstractionAbs a1 a2 $ \a2' -> checkSubtypeIsEqual a2' (absBody b2)-        MetaV{} -> patternViolation         Dummy{} -> return () -- TODO: this shouldn't happen but                              -- currently does because of generalized                              -- metas being created in a dummy context-        _ -> patternViolation-      MetaV{} -> patternViolation+        a -> patternViolation (unblockOnAnyMetaIn a)       -- TODO: check subtyping for Size< types       _ -> return () @@ -1185,7 +1268,7 @@           -- Note: no eta-expansion of new meta possible/necessary.           -- Add the size constraint @y args `dir` u@.           let yArgs = MetaV y $ map Apply args-          addConstraint $ dirToCmp (`ValueCmp` AsSizes) dir yArgs u+          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.@@ -1200,7 +1283,7 @@   :: ( Show a, PrettyTCM a, NoProjectedVar a      -- , Normalise a, TermLike a, Subst Term a      , ReduceAndEtaContract a-     , PrettyTCM b, Subst Term b+     , PrettyTCM b, TermSubst b      )   => a  -- ^ Meta variable arguments.   -> b  -- ^ Right hand side.@@ -1210,7 +1293,6 @@   loop (args, v) = do     reportSDoc "tc.meta.assign.proj" 45 $ "meta args: " <+> prettyTCM args     args <- callByName $ reduceAndEtaContract args-    -- args <- etaContract =<< normalise args     reportSDoc "tc.meta.assign.proj" 45 $ "norm args: " <+> prettyTCM args     reportSDoc "tc.meta.assign.proj" 85 $ "norm args: " <+> text (show args)     let done = ret args v@@ -1219,10 +1301,10 @@         reportSDoc "tc.meta.assign.proj" 40 $           "no projected var found in args: " <+> prettyTCM args         done-      Left (ProjVarExc i _) -> etaExpandProjectedVar i (args, v) done loop+      Left (ProjectedVar i _) -> etaExpandProjectedVar i (args, v) done loop  -- | Eta-expand a de Bruijn index of record type in context and passed term(s).-etaExpandProjectedVar :: (PrettyTCM a, Subst Term a) => Int -> a -> TCM c -> (a -> TCM c) -> TCM c+etaExpandProjectedVar :: (PrettyTCM a, TermSubst a) => Int -> a -> TCM c -> (a -> TCM c) -> TCM c etaExpandProjectedVar i v fail succeed = do   reportSDoc "tc.meta.assign.proj" 40 $     "trying to expand projected variable" <+> prettyTCM (var i)@@ -1235,38 +1317,39 @@  -- | Check whether one of the meta args is a projected var. class NoProjectedVar a where-  noProjectedVar :: a -> Either ProjVarExc ()+  noProjectedVar :: a -> Either ProjectedVar () -data ProjVarExc = ProjVarExc Int [(ProjOrigin, QName)]+  default noProjectedVar+    :: (NoProjectedVar b, Foldable t, t b ~ a)+    => a -> Either ProjectedVar ()+  noProjectedVar = Fold.mapM_ noProjectedVar +instance NoProjectedVar a => NoProjectedVar (Arg a)+instance NoProjectedVar a => NoProjectedVar [a]+ instance NoProjectedVar Term where-  noProjectedVar t =-    case t of+  noProjectedVar = \case       Var i es-        | qs@(_:_) <- takeWhileJust id $ map isProjElim es -> Left $ ProjVarExc i qs+        | qs@(_:_) <- takeWhileJust id $ map isProjElim es+        -> Left $ ProjectedVar i qs       -- Andreas, 2015-09-12 Issue #1316:       -- Also look in inductive record constructors-      Con (ConHead _ Inductive (_:_)) _ es | Just vs <- allApplyElims es -> noProjectedVar vs+      Con (ConHead _ IsRecord{} Inductive _) _ es+        | Just vs <- allApplyElims es+        -> noProjectedVar vs       _ -> return () -instance NoProjectedVar a => NoProjectedVar (Arg a) where-  noProjectedVar = Fold.mapM_ noProjectedVar--instance NoProjectedVar a => NoProjectedVar [a] where-  noProjectedVar = Fold.mapM_ noProjectedVar-- -- | Normalize just far enough to be able to eta-contract maximally.-class (TermLike a, Subst Term a, Reduce a) => ReduceAndEtaContract a where+class (TermLike a, TermSubst a, Reduce a) => ReduceAndEtaContract a where   reduceAndEtaContract :: a -> TCM a    default reduceAndEtaContract-    :: (Traversable f, TermLike b, Subst Term b, Reduce b, ReduceAndEtaContract b, f b ~ a)+    :: (Traversable f, TermLike b, Subst b, Reduce b, ReduceAndEtaContract b, f b ~ a)     => a -> TCM a   reduceAndEtaContract = Trav.mapM reduceAndEtaContract -instance ReduceAndEtaContract a => ReduceAndEtaContract [a] where-instance ReduceAndEtaContract a => ReduceAndEtaContract (Arg a) where+instance ReduceAndEtaContract a => ReduceAndEtaContract [a]+instance ReduceAndEtaContract a => ReduceAndEtaContract (Arg a)  instance ReduceAndEtaContract Term where   reduceAndEtaContract u = do@@ -1342,13 +1425,13 @@   let grps = groupOn fst ids   concat <$> mapM makeLinear grps   where-    -- | Non-determinism can be healed if type is singleton. [Issue 593]-    --   (Same as for irrelevance.)+    -- Non-determinism can be healed if type is singleton. [Issue 593]+    -- (Same as for irrelevance.)     makeLinear :: SubstCand -> ExceptT () TCM SubstCand     makeLinear []            = __IMPOSSIBLE__     makeLinear grp@[_]       = return grp     makeLinear (p@(i,t) : _) =-      ifM ((Right True ==) <$> do lift . isSingletonTypeModuloRelevance =<< typeOfBV i)+      ifM ((Right True ==) <$> do lift . runBlocked . isSingletonTypeModuloRelevance =<< typeOfBV i)         (return [p])         (throwError ()) @@ -1359,7 +1442,7 @@ data InvertExcept   = CantInvert                -- ^ Cannot recover.   | NeutralArg                -- ^ A potentially neutral arg: can't invert, but can try pruning.-  | ProjectedVar Int [(ProjOrigin, QName)]  -- ^ Try to eta-expand var to remove projs.+  | ProjVar ProjectedVar      -- ^ Try to eta-expand var to remove projs.  -- | Check that arguments @args@ to a metavar are in pattern fragment. --   Assumes all arguments already in whnf and eta-reduced.@@ -1395,7 +1478,7 @@          -- π i := x  try to eta-expand projection π away!         Var i es | Just qs <- mapM isProjElim es ->-          throwError $ ProjectedVar i qs+          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@@ -1404,7 +1487,7 @@                | isIrrelevant info = return vars                | otherwise                              = failure           irrProj <- optIrrelevantProjections <$> pragmaOptions-          (lift $ isRecordConstructor $ conName c) >>= \case+          lift (isRecordConstructor $ conName c) >>= \case             Just (_, r@Record{ recFields = fs })               | YesEta <- recEtaEquality r  -- Andreas, 2019-11-10, issue #4185: only for eta-records               , length fs == length es@@ -1420,6 +1503,7 @@                          }                        , argInfoOrigin   = min (getOrigin info) (getOrigin info')                        , argInfoFreeVariables = unknownFreeVariables+                       , argInfoAnnotation    = argInfoAnnotation info'                        }                     vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es                 res <- loop $ zipWith aux vs fs@@ -1477,7 +1561,7 @@       -- 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." ++ show x+      let s = "unsolved#meta." ++ prettyShow x       n <- freshName r s       let q = A.QName m n @@ -1492,7 +1576,7 @@         ]        -- Add the new postulate to the signature.-      addConstant q $ defaultDefn defaultArgInfo q t Axiom+      addConstant q $ defaultDefn defaultArgInfo q t defaultAxiom        -- Solve the meta.       let inst = InstV [] $ Def q []@@ -1504,7 +1588,7 @@     -- codomains by Setω.     dummyTypeToOmega t =       case telView' t of-        TelV tel (El _ Dummy{}) -> abstract tel topSort+        TelV tel (El _ Dummy{}) -> abstract tel (sort $ Inf IsFibrant 0)         _ -> t  -- | Sort metas in dependency order.

src/full/Agda/TypeChecking/MetaVars/Mention.hs view

@@ -3,6 +3,7 @@  import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet+import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -15,7 +16,7 @@ mentionsMeta = mentionsMetas . HashSet.singleton  instance MentionsMeta Term where-  mentionsMetas xs v = case v of+  mentionsMetas xs = \case     Var _ args   -> mm args     Lam _ b      -> mm b     Lit{}        -> False@@ -28,7 +29,8 @@     DontCare v   -> False   -- we don't have to look inside don't cares when deciding to wake constraints     MetaV y args -> HashSet.member y xs || mm args   -- TODO: we really only have to look one level deep at meta args     where-      mm v = mentionsMetas xs v+      mm :: forall t. MentionsMeta t => t -> Bool+      mm = mentionsMetas xs  instance MentionsMeta Level where   mentionsMetas xs (Max _ as) = mentionsMetas xs as@@ -36,23 +38,24 @@ instance MentionsMeta PlusLevel where   mentionsMetas xs (Plus _ a) = mentionsMetas xs a -instance MentionsMeta LevelAtom where-  mentionsMetas xs l = case l of-    MetaLevel m vs   -> HashSet.member m xs || mentionsMetas xs vs-    BlockedLevel m _ -> HashSet.member m xs  -- if it's blocked on a different meta it doesn't matter if it mentions the meta somewhere else-    UnreducedLevel l -> mentionsMetas xs l-    NeutralLevel _ l -> mentionsMetas xs l+instance MentionsMeta Blocker where+  mentionsMetas xs (UnblockOnAll bs)  = mentionsMetas xs $ Set.toList bs+  mentionsMetas xs (UnblockOnAny bs)  = mentionsMetas xs $ Set.toList bs+  mentionsMetas xs (UnblockOnMeta x)  = HashSet.member x xs+  mentionsMetas xs UnblockOnProblem{} = False  instance MentionsMeta Type where     mentionsMetas xs (El s t) = mentionsMetas xs (s, t)  instance MentionsMeta Sort where-  mentionsMetas xs s = case s of+  mentionsMetas xs = \case     Type l     -> mentionsMetas xs l     Prop l     -> mentionsMetas xs l-    Inf        -> False+    Inf _ _    -> False+    SSet l     -> mentionsMetas xs l     SizeUniv   -> False-    PiSort a s -> mentionsMetas xs (a, s)+    LockUniv   -> False+    PiSort a s1 s2 -> mentionsMetas xs (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@@ -64,7 +67,7 @@  instance MentionsMeta t => MentionsMeta (Arg t) where   mentionsMetas xs a | isIrrelevant a = False-  -- ^ we don't have to look inside irrelevant arguments when deciding to wake constraints+  -- we don't have to look inside irrelevant arguments when deciding to wake constraints   mentionsMetas xs a = mentionsMetas xs (unArg a)  instance MentionsMeta t => MentionsMeta (Dom t) where@@ -98,14 +101,12 @@   mentionsMetas xs = mentionsMetas xs . theConstraint  instance MentionsMeta Constraint where-  mentionsMetas xs c = case c of+  mentionsMetas xs = \case     ValueCmp _ t u v    -> mm (t, u, v)     ValueCmpOnFace _ p t u v    -> mm ((p,t), u, v)     ElimCmp _ _ t v as bs -> mm ((t, v), (as, bs))     LevelCmp _ u v      -> mm (u, v)-    TelCmp a b _ u v    -> mm ((a, b), (u, v))     SortCmp _ a b       -> mm (a, b)-    Guarded{}           -> False  -- This gets woken up when the problem it's guarded by is solved     UnBlock _           -> True   -- this might be a postponed typechecking                                   -- problem and we don't have a handle on                                   -- what metas it depends on@@ -115,12 +116,13 @@     CheckFunDef{}       -> True   -- not sure what metas this depends on     HasBiggerSort a     -> mm a     HasPTSRule a b      -> mm (a, b)-    UnquoteTactic bl tac hole goal -> case bl of-      Nothing -> False-      Just m  -> HashSet.member m xs+    UnquoteTactic tac hole goal -> False     CheckMetaInst m     -> True   -- TODO+    CheckLockedVars a b c d -> mm ((a, b), (c, d))+    UsableAtModality mod t -> mm t     where-      mm v = mentionsMetas xs v+      mm :: forall t. MentionsMeta t => t -> Bool+      mm = mentionsMetas xs  instance MentionsMeta CompareAs where   mentionsMetas xs = \case

src/full/Agda/TypeChecking/MetaVars/Occurs.hs view

@@ -1,7 +1,4 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NondecreasingIndentation  #-}  {- | The occurs check for unification.  Does pruning on the fly. @@ -17,6 +14,7 @@ module Agda.TypeChecking.MetaVars.Occurs where  import Control.Monad+import Control.Monad.Except import Control.Monad.Reader  import Data.Foldable (traverse_)@@ -27,12 +25,12 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.IntSet (IntSet)-import Data.Traversable (traverse)  import qualified Agda.Benchmarking as Bench  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars  import Agda.TypeChecking.Constraints () -- instances import Agda.TypeChecking.Monad@@ -48,13 +46,6 @@ import {-# SOURCE #-} Agda.TypeChecking.MetaVars  import Agda.Utils.Either--import Agda.Utils.Except-  ( ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )- import Agda.Utils.Lens import Agda.Utils.List (downFrom) import Agda.Utils.Maybe@@ -193,7 +184,7 @@         , "has relevance"         , prettyTCM (getRelevance dmod)         ]-      abort $ MetaIrrelevantSolution m $ Def d []+      abort neverUnblock $ MetaIrrelevantSolution m $ Def d []     unless (er || usableQuantity dmod) $ do       reportSDoc "tc.meta.occurs" 35 $ hsep         [ "occursCheck: definition"@@ -201,15 +192,83 @@         , "has quantity"         , prettyTCM (getQuantity dmod)         ]-      abort $ MetaErasedSolution m $ Def d []+      abort neverUnblock $ MetaErasedSolution m $ Def d [] +metaCheck :: MetaId -> OccursM MetaId+metaCheck m = do+  cxt <- ask+  let rel = getRelevance cxt+      qnt = getQuantity cxt+      m0  = occMeta $ feExtra cxt++  -- Check for loop+  --   don't fail hard on this, since we might still be on the top-level+  --   after some killing (Issue 442)+  --+  -- Andreas, 2013-02-18  Issue 795 demonstrates that a recursive+  -- occurrence of a meta could be solved by the identity.+  --   ? (Q A) = Q (? A)+  -- So, do not throw an error.+  -- I guess the error was there from times when occurrence check+  -- was done after the "lhs=linear variables" check, but now+  -- occurrence check comes first.+  -- WAS:+  -- when (m == m') $ if ctx == Top then patternViolation else+  --   abort ctx $ MetaOccursInItself m'+  when (m == m0) $ patternViolation' neverUnblock 50 $ "occursCheck failed: Found " ++ prettyShow m++  mv <- lookupMeta m+  let mmod = getMetaModality mv+      mmod' = setRelevance rel $ setQuantity qnt $ mmod+  if (mmod `moreUsableModality` mmod') then return m else do+    reportSDoc "tc.meta.occurs" 35 $ hsep+      [ "occursCheck: meta variable"+      , prettyTCM m+      , "has relevance"+      , prettyTCM (getRelevance mmod)+      , "and quantity"+      , prettyTCM (getQuantity mmod)+      ]+    allowAssign <- asksTC envAssignMetas+    -- 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+    -- a new meta with that modality and solving the old one with+    -- it. Don't do this if the meta occurs in a flexible or unguarded+    -- position:+    -- - If it is in a flexible position, it could disappear when+    --   another meta is solved, so promotion is maybe not necessary.+    -- - If it is in a top-level position, we can instead solve the+    --   equation by instantiating the other way around, so promotion+    --   is not necessary.+    let fail reason = do+          reportSDoc "tc.meta.occurs" 20 $ "Meta occurs check found bad relevance"+          reportSDoc "tc.meta.occurs" 20 $ "aborting because" <+> reason+          patternViolation $ unblockOnMeta m+    when (mvFrozen mv == Frozen)             $ fail "meta is frozen"+    unless (isOpenMeta $ mvInstantiation mv) $ fail "meta is already solved"+    unless allowAssign                       $ fail "assigning metas is not allowed here"+    when (isFlexible cxt)                    $ fail "occurrence is flexible"+    when (isUnguarded cxt)                   $ fail "occurrence is unguarded"++    reportSDoc "tc.meta.occurs" 20 $ "Promoting meta" <+> prettyTCM m <+> "to modality" <+> prettyTCM mmod'+    let info' = setModality mmod' $ mvInfo mv+    m' <- liftTCM $ newMeta Instantiable info' (mvPriority mv) (mvPermutation mv) (mvJudgement mv)+    reportSDoc "tc.meta.occurs.qnt" 20 $ hsep+       [ "occursCheck: new meta variable"+       , prettyTCM m'+       ]+    liftTCM $ assignTerm m [] $ MetaV m' []+    reportSDoc "tc.meta.occurs" 35 $ "New name for" <+> prettyTCM m <+> "is" <+> prettyTCM m'+    return m'+ -- | 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 <- IntMap.keysSet . theVarMap <$> asks (occVars . feExtra)+  xs <- asks ((IntMap.keysSet . theVarMap) . (occVars . feExtra))   -- Bound variables are allowed, and those mentioned in occVars.   return $ \ i -> i < n || (i - n) `IntSet.member` xs @@ -255,13 +314,13 @@  -- ** Error throwing during occurs check. -patternViolation' :: MonadTCM m => Int -> String -> m a-patternViolation' n err = liftTCM $ do+patternViolation' :: MonadTCM m => Blocker -> Int -> String -> m a+patternViolation' unblock n err = liftTCM $ do   reportSLn "tc.meta.occurs" n err-  patternViolation+  patternViolation unblock -abort :: TypeError -> OccursM a-abort err = do+abort :: Blocker -> TypeError -> OccursM a+abort unblock err = do   ctx <- ask   lift $ do     if | isIrrelevant ctx                    -> soft@@ -269,7 +328,7 @@        | otherwise -> soft   where   hard = typeError err -- here, throw an uncatchable error (unsolvable constraint)-  soft = patternViolation' 70 (show err) -- throws a PatternErr, which leads to delayed constraint+  soft = patternViolation' unblock 70 (show err) -- throws a PatternErr, which leads to delayed constraint  --------------------------------------------------------------------------- -- * Implementation of the occurs check.@@ -322,7 +381,7 @@     -- Produce nicer error messages     nicerErrorMessage :: TCM a -> TCM a     nicerErrorMessage f = f `catchError` \ err -> case err of-      TypeError _ cl -> case clValue cl of+      TypeError _ _ cl -> case clValue cl of         MetaOccursInItself{} ->           typeError . GenericDocError =<<             fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to")@@ -365,13 +424,13 @@     -- occurs' ctx $ ignoreBlocking v  -- fails test/succeed/DontPruneBlocked     let flexIfBlocked = case vb of           -- Don't fail on blocked terms or metas-          -- Blocked _ MetaV{} -> id  -- does not help with issue #856-          Blocked{}    -> flexibly+          Blocked _ MetaV{} -> id+          Blocked b _ -> flexibly . addOrUnblocker b           -- Re #3594, do not fail hard when Underapplied:           -- the occurrence could be computed away after eta expansion.           NotBlocked{blockingStatus = Underapplied} -> flexibly           NotBlocked{} -> id-    v <- return $ ignoreBlocking vb+    let v = ignoreBlocking vb     flexIfBlocked $ do         ctx <- ask         let m = occMeta . feExtra $ ctx@@ -381,7 +440,7 @@           nest 2 $ text $ show v         case v of           Var i es   -> do-            allowed <- getAll . ($ mempty) <$> variable i+            allowed <- getAll . ($ unitModality) <$> variable i             if allowed then Var i <$> weakly (occurs es) else do               -- if the offending variable is of singleton type,               -- eta-expand it away@@ -391,17 +450,15 @@               isST <- isSingletonType t               reportSDoc "tc.meta.occurs" 35 $ nest 2 $ "(after singleton test)"               case isST of-                -- cannot decide, blocked by meta-var-                Left mid -> patternViolation' 70 $ "Disallowed var " ++ show i ++ " not obviously singleton"                 -- not a singleton type-                Right Nothing ->+                Nothing ->                   -- #4480: Only hard fail if the variable is not in scope. Wrong modality/relevance                   -- could potentially be salvaged by eta expansion.-                  ifM (($ i) <$> allowedVars)-                      (patternViolation' 70 $ "Disallowed var " ++ show i ++ " due to modality/relevance")-                      (strongly $ abort $ MetaCannotDependOn m i)+                  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 i)                 -- is a singleton type with unique inhabitant sv-                Right (Just sv) -> return $ sv `applyE` es+                (Just sv) -> return $ sv `applyE` es           Lam h f     -> Lam h <$> occurs f           Level l     -> Level <$> occurs l           Lit l       -> return v@@ -410,26 +467,17 @@           Def d es    -> do             definitionCheck d             Def d <$> occDef d es-          Con c ci vs -> Con c ci <$> occurs vs  -- if strongly rigid, remain so+          Con c ci vs -> do+            definitionCheck (conName c)+            Con c ci <$> occurs vs  -- if strongly rigid, remain so           Pi a b      -> uncurry Pi <$> occurs (a,b)           Sort s      -> Sort <$> do underRelevance NonStrict $ occurs s           MetaV m' es -> do-              -- Check for loop-              --   don't fail hard on this, since we might still be on the top-level-              --   after some killing (Issue 442)-              ---              -- Andreas, 2013-02-18  Issue 795 demonstrates that a recursive-              -- occurrence of a meta could be solved by the identity.-              --   ? (Q A) = Q (? A)-              -- So, do not throw an error.-              -- I guess the error was there from times when occurrence check-              -- was done after the "lhs=linear variables" check, but now-              -- occurrence check comes first.-              -- WAS:-              -- when (m == m') $ if ctx == Top then patternViolation else-              --   abort ctx $ MetaOccursInItself m'-              when (m == m') $ patternViolation' 50 $ "occursCheck failed: Found " ++ prettyShow m+            m' <- metaCheck m' +            addOrUnblocker (unblockOnMeta m') $ do+                         -- If getting stuck here, we need to trigger wakeup if this meta is+                         -- solved.               -- The arguments of a meta are in a flexible position               (MetaV m' <$> do flexibly $ occurs es) `catchError` \ err -> do                 ctx <- ask@@ -474,9 +522,9 @@       Def d vs   -> metaOccurs m d >> metaOccurs m vs       Con c _ vs -> metaOccurs m vs       Pi a b     -> metaOccurs m (a,b)-      Sort s     -> metaOccurs m s-      MetaV m' vs | m == m' -> patternViolation' 50 $ "Found occurrence of " ++ prettyShow m-                  | otherwise -> metaOccurs m vs+      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  instance Occurs QName where   occurs d = __IMPOSSIBLE__@@ -505,6 +553,7 @@   metaOccurs m Record{ recConHead = c }     = metaOccursQName m $ conName c   metaOccurs m Constructor{}                = return ()   metaOccurs m Primitive{}                  = return ()+  metaOccurs m PrimitiveSort{}              = __IMPOSSIBLE__   metaOccurs m AbstractDefn{}               = __IMPOSSIBLE__   metaOccurs m GeneralizableVar{}           = __IMPOSSIBLE__ @@ -516,32 +565,17 @@ instance Occurs Level where   occurs (Max n as) = Max n <$> occurs as -  metaOccurs m (Max _ as) = metaOccurs m as+  metaOccurs m (Max _ as) = addOrUnblocker (unblockOnAnyMetaIn as) $ metaOccurs m as+                            -- TODO: Should only be blocking metas in as. But any meta that can+                            --       let the Max make progress needs to be included. For instance,+                            --       _1 ⊔ _2 = _1 should unblock on _2, even though _1 is the meta+                            --       failing occurs check.  instance Occurs PlusLevel where   occurs (Plus n l) = Plus n <$> occurs l    metaOccurs m (Plus n l) = metaOccurs m l -instance Occurs LevelAtom where-  occurs l = do-    unfold l >>= \case-      MetaLevel m' args -> do-        MetaV m' args <- occurs (MetaV m' args)-        return $ MetaLevel m' args-      NeutralLevel r v  -> NeutralLevel r  <$> occurs v-      BlockedLevel m' v -> BlockedLevel m' <$> do flexibly $ occurs v-      UnreducedLevel v  -> UnreducedLevel  <$> occurs v--  metaOccurs m l = do-    l <- instantiate l-    case l of-      MetaLevel m' args -> metaOccurs m $ MetaV m' args-      NeutralLevel _ v  -> metaOccurs m v-      BlockedLevel _ v  -> metaOccurs m v-      UnreducedLevel v  -> metaOccurs m v-- instance Occurs Type where   occurs (El s v) = uncurry El <$> occurs (s,v) @@ -550,16 +584,18 @@ instance Occurs Sort where   occurs s = do     unfold s >>= \case-      PiSort a s2 -> do-        s1' <- flexibly $ occurs $ getSort a-        a'  <- (a $>) . El s1' <$> do flexibly $ occurs $ unEl $ unDom a-        s2' <- mapAbstraction a' (flexibly . underBinder . occurs) s2-        return $ PiSort a' s2'+      PiSort a s1 s2 -> do+        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'       FunSort s1 s2 -> FunSort <$> flexibly (occurs s1) <*> flexibly (occurs s2)       Type a     -> Type <$> occurs a       Prop a     -> Prop <$> occurs a-      s@Inf      -> return s+      s@Inf{}    -> return s+      SSet a     -> SSet <$> occurs a       s@SizeUniv -> return s+      s@LockUniv -> return s       UnivSort s -> UnivSort <$> do flexibly $ occurs s       MetaS x es -> do         MetaV x es <- occurs (MetaV x es)@@ -572,12 +608,14 @@   metaOccurs m s = do     s <- instantiate s     case s of-      PiSort a s -> metaOccurs m (a,s)+      PiSort a s1 s2 -> metaOccurs m (a,s1,s2)       FunSort s1 s2 -> metaOccurs m (s1,s2)       Type a     -> metaOccurs m a       Prop a     -> metaOccurs m a-      Inf        -> return ()+      Inf _ _    -> return ()+      SSet a     -> metaOccurs m a       SizeUniv   -> return ()+      LockUniv   -> return ()       UnivSort s -> metaOccurs m s       MetaS x es -> metaOccurs m $ MetaV x es       DefS d es  -> metaOccurs m $ Def d es@@ -592,7 +630,7 @@   metaOccurs m (Apply a) = metaOccurs m a   metaOccurs m (IApply x y a) = metaOccurs m (x,(y,a)) -instance (Occurs a, Subst t a) => Occurs (Abs a) where+instance (Occurs a, Subst a) => Occurs (Abs a) where   occurs b@(Abs s _) = Abs   s <$> do underAbstraction_ b $ underBinder . occurs   occurs (NoAbs s x) = NoAbs s <$> occurs x @@ -612,6 +650,11 @@    metaOccurs m (x,y) = metaOccurs m x >> metaOccurs m y +instance (Occurs a, Occurs b, Occurs c) => Occurs (a,b,c) where+  occurs (x,y,z) = (,,) <$> occurs x <*> occurs y <*> occurs z++  metaOccurs m (x,y,z) = metaOccurs m x >> metaOccurs m y >> metaOccurs m z+ --------------------------------------------------------------------------- -- * Pruning: getting rid of flexible occurrences. @@ -625,13 +668,13 @@ --   we cannot prune, because the offending variables could be removed by --   reduction for a suitable instantiation of the meta variable. prune-  :: MonadMetaSolver m+  :: (PureTCM m, MonadMetaSolver m)   => MetaId         -- ^ Meta to prune.   -> Args           -- ^ Arguments to meta variable.   -> (Nat -> Bool)  -- ^ Test for allowed variable (de Bruijn index).   -> m PruneResult prune m' vs xs = do-  caseEitherM (runExceptT $ mapM (hasBadRigid xs) $ map unArg vs)+  caseEitherM (runExceptT $ mapM ((hasBadRigid xs) . unArg) vs)     (const $ return PrunedNothing) $ \ kills -> do     reportSDoc "tc.meta.kill" 10 $ vcat       [ "attempting kills"@@ -652,7 +695,7 @@ --   we cannot prune at all as one of the meta args is matchable. --   (See issue 1147.) hasBadRigid-  :: (MonadReduce m, HasConstInfo m, MonadAddContext m)+  :: PureTCM m   => (Nat -> Bool)      -- ^ Test for allowed variable (de Bruijn index).   -> Term               -- ^ Argument of meta variable.   -> ExceptT () m Bool  -- ^ Exception if argument is matchable.@@ -717,7 +760,7 @@ --   Reduces the term successively to remove variables in dead subterms. --   This fixes issue 1386. rigidVarsNotContainedIn-  :: (MonadReduce m, MonadAddContext m, MonadTCEnv m, MonadDebug m, AnyRigid a)+  :: (PureTCM m, AnyRigid a)   => a   -> (Nat -> Bool)   -- ^ Test for allowed variable (de Bruijn index).   -> m Bool@@ -743,7 +786,7 @@ --   We need to successively reduce the expression to do this.  class AnyRigid a where-  anyRigid :: (MonadReduce tcm, MonadAddContext tcm)+  anyRigid :: (PureTCM tcm)            => (Nat -> tcm Bool) -> a -> tcm Bool  instance AnyRigid Term where@@ -781,9 +824,11 @@     case s of       Type l     -> anyRigid f l       Prop l     -> anyRigid f l-      Inf        -> return False+      Inf _ _    -> return False+      SSet l     -> anyRigid f l       SizeUniv   -> return False-      PiSort a s -> return False+      LockUniv   -> return False+      PiSort a s1 s2 -> return False       FunSort s1 s2 -> return False       UnivSort s -> anyRigid f s       MetaS{}    -> return False@@ -796,16 +841,7 @@ instance AnyRigid PlusLevel where   anyRigid f (Plus _ l)    = anyRigid f l -instance AnyRigid LevelAtom where-  anyRigid f l =-    case l of-      MetaLevel{} -> return False-      NeutralLevel MissingClauses _ -> return False-      NeutralLevel _              l -> anyRigid f l-      BlockedLevel _              l -> anyRigid f l-      UnreducedLevel              l -> anyRigid f l--instance (Subst t a, AnyRigid a) => AnyRigid (Abs a) where+instance (Subst a, AnyRigid a) => AnyRigid (Abs a) where   anyRigid f b = underAbstraction_ b $ anyRigid f  instance AnyRigid a => AnyRigid (Arg a) where@@ -924,7 +960,7 @@           -- telescope. Drop x from xs (and shift indices) and recurse with           -- `strengthen x B`.           let ys = down (IntSet.delete 0 xs)-          (ys, b) <- go args ys $ strengthen __IMPOSSIBLE__ b+          (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 (IntSet.insert 0 $ up ys, b)@@ -942,23 +978,24 @@           return (up zs, b)  reallyNotFreeIn :: (MonadReduce m) => IntSet -> Type -> m (IntSet, Type)-reallyNotFreeIn xs a | IntSet.null xs = return (xs, a)  -- Shortcut+reallyNotFreeIn xs a | IntSet.null xs = return (xs, a) -- Shortcut reallyNotFreeIn xs a = do   let fvs      = freeVars a       anywhere = allVars fvs       rigid    = IntSet.unions [stronglyRigidVars fvs, unguardedVars fvs]       nonrigid = IntSet.difference anywhere rigid-      hasNo    = IntSet.null . IntSet.intersection xs-  if | hasNo nonrigid ->-        -- No non-rigid occurrences. We can't do anything about the rigid-        -- occurrences so drop those and leave `a` untouched.-        return (IntSet.difference xs rigid, a)-     | otherwise -> do-        -- If there are non-rigid occurrences we need to reduce a to see if-        -- we can get rid of them (#3177).-        (fvs , a) <- forceNotFree (IntSet.difference xs rigid) a-        let xs = IntMap.keysSet $ IntMap.filter (== NotFree) fvs-        return (xs , a)+      hasNo    = IntSet.disjoint xs+  if hasNo nonrigid+    then+       -- No non-rigid occurrences. We can't do anything about the rigid+       -- occurrences so drop those and leave `a` untouched.+       return (IntSet.difference xs rigid, a)+    else do+      -- If there are non-rigid occurrences we need to reduce a to see if+      -- we can get rid of them (#3177).+      (fvs, a) <- forceNotFree (IntSet.difference xs rigid) a+      let xs = IntMap.keysSet $ IntMap.filter (== NotFree) fvs+      return (xs, a)  -- | Instantiate a meta variable with a new one that only takes --   the arguments which are not pruneable.

src/full/Agda/TypeChecking/Monad.hs view

@@ -11,6 +11,7 @@     , module Agda.TypeChecking.Monad.Mutual     , module Agda.TypeChecking.Monad.Open     , module Agda.TypeChecking.Monad.Options+    , module Agda.TypeChecking.Monad.Pure     , module Agda.TypeChecking.Monad.Signature     , module Agda.TypeChecking.Monad.SizedTypes     , module Agda.TypeChecking.Monad.State@@ -31,6 +32,7 @@ import Agda.TypeChecking.Monad.Mutual import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.Open+import Agda.TypeChecking.Monad.Pure import Agda.TypeChecking.Monad.Signature import Agda.TypeChecking.Monad.SizedTypes import Agda.TypeChecking.Monad.State

src/full/Agda/TypeChecking/Monad/Base.hs view

@@ -1,4314 +1,4730 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-} -- for type equality ~--module Agda.TypeChecking.Monad.Base where--import Prelude hiding (null)--import qualified Control.Concurrent as C-import qualified Control.Exception as E--import qualified Control.Monad.Fail as Fail--import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer hiding ((<>))-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Applicative hiding (empty)--import Data.Array (Ix)-import Data.Function-import Data.Int-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map -- hiding (singleton, null, empty)-import Data.Monoid ( Monoid, mempty, mappend )-import Data.Sequence (Seq)-import Data.Set (Set)-import qualified Data.Set as Set -- hiding (singleton, null, empty)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HMap-import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )-import Data.Data (Data, toConstr)-import Data.Foldable (Foldable)-import Data.String-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T--import Data.IORef--import qualified System.Console.Haskeline as Haskeline--import Agda.Benchmarking (Benchmark, Phase)--import Agda.Syntax.Concrete (TopLevelModuleName)-import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Definitions-  (NiceDeclaration, DeclarationWarning, declarationWarningName)-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract (AllNames)-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Generic (TermLike(..))-import Agda.Syntax.Parser (ParseWarning)-import Agda.Syntax.Parser.Monad (parseWarningName)-import Agda.Syntax.Treeless (Compiled)-import Agda.Syntax.Notation-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base-import qualified Agda.Syntax.Info as Info--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Coverage.SplitTree-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)---- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend--- conflicts with Args, defined in Agda.Syntax.Internal and also imported here.--- This only matters when interpreted in ghci, which sees all of the module's--- exported symbols, not just the ones defined in the `.hs-boot`. See the--- comment in ../../Compiler/Backend.hs-boot-import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args)--import Agda.Interaction.Options-import Agda.Interaction.Options.Warnings-import {-# SOURCE #-} Agda.Interaction.Response-  (InteractionOutputCallback, defaultInteractionOutputCallback)-import Agda.Interaction.Highlighting.Precise-  (CompressedFile, HighlightingInfo)-import Agda.Interaction.Library--import Agda.Utils.Benchmark (MonadBench(..))-import Agda.Utils.Except-  ( Error(strMsg)-  , ExceptT-  , MonadError(catchError, throwError)-  , mapExceptT-  )-import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.Hash-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.ListT-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty-import Agda.Utils.Singleton-import Agda.Utils.SmallSet (SmallSet)-import qualified Agda.Utils.SmallSet as SmallSet-import Agda.Utils.Update-import Agda.Utils.WithDefault ( collapseDefault )--import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Type checking state------------------------------------------------------------------------------data TCState = TCSt-  { stPreScopeState   :: !PreScopeState-    -- ^ The state which is frozen after scope checking.-  , stPostScopeState  :: !PostScopeState-    -- ^ The state which is modified after scope checking.-  , stPersistentState :: !PersistentTCState-    -- ^ State which is forever, like a diamond.-  }--class Monad m => ReadTCState m where-  getTCState :: m TCState-  locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b--  withTCState :: (TCState -> TCState) -> m a -> m a-  withTCState = locallyTCState id--instance ReadTCState m => ReadTCState (MaybeT m) where-  getTCState = lift getTCState-  locallyTCState l = mapMaybeT . locallyTCState l--instance ReadTCState m => ReadTCState (ListT m) where-  getTCState = lift getTCState-  locallyTCState l f = ListT . locallyTCState l f . runListT--instance ReadTCState m => ReadTCState (ExceptT err m) where-  getTCState = lift getTCState-  locallyTCState l = mapExceptT . locallyTCState l--instance ReadTCState m => ReadTCState (ReaderT r m) where-  getTCState = lift getTCState-  locallyTCState l = mapReaderT . locallyTCState l--instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m) where-  getTCState = lift getTCState-  locallyTCState l = mapWriterT . locallyTCState l--instance ReadTCState m => ReadTCState (StateT s m) where-  getTCState = lift getTCState-  locallyTCState l = mapStateT . locallyTCState l--instance Show TCState where-  show _ = "TCSt{}"--data PreScopeState = PreScopeState-  { stPreTokens             :: !CompressedFile -- from lexer-    -- ^ Highlighting info for tokens (but not those tokens for-    -- which highlighting exists in 'stSyntaxInfo').-  , stPreImports            :: !Signature  -- XX populated by scope checker-    -- ^ Imported declared identifiers.-    --   Those most not be serialized!-  , stPreImportedModules    :: !(Set ModuleName)  -- imports logic-  , stPreModuleToSource     :: !ModuleToSource   -- imports-  , stPreVisitedModules     :: !VisitedModules   -- imports-  , stPreScope              :: !ScopeInfo-    -- generated by scope checker, current file:-    -- which modules you have, public definitions, current file, maps concrete names to abstract names.-  , stPrePatternSyns        :: !A.PatternSynDefns-    -- ^ Pattern synonyms of the current file.  Serialized.-  , stPrePatternSynImports  :: !A.PatternSynDefns-    -- ^ Imported pattern synonyms.  Must not be serialized!-  , stPreGeneralizedVars    :: !(Strict.Maybe (Set QName))-    -- ^ Collected generalizable variables; used during scope checking of terms-  , stPrePragmaOptions      :: !PragmaOptions-    -- ^ Options applying to the current file. @OPTIONS@-    -- pragmas only affect this field.-  , stPreImportedBuiltins   :: !(BuiltinThings PrimFun)-  , stPreImportedDisplayForms :: !DisplayForms-    -- ^ Display forms added by someone else to imported identifiers-  , stPreImportedInstanceDefs :: !InstanceTable-  , stPreForeignCode        :: !(Map BackendName [ForeignCode])-    -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.-    -- Does not include code for imported modules.-  , stPreFreshInteractionId :: !InteractionId-  , stPreImportedUserWarnings :: !(Map A.QName String)-    -- ^ Imported @UserWarning@s, not to be stored in the @Interface@-  , stPreLocalUserWarnings    :: !(Map A.QName String)-    -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@-  , stPreWarningOnImport      :: !(Strict.Maybe String)-    -- ^ Whether the current module should raise a warning when opened-  , stPreImportedPartialDefs :: !(Set QName)-    -- ^ Imported partial definitions, not to be stored in the @Interface@-  }--type DisambiguatedNames = IntMap A.QName--type ConcreteNames = Map Name [C.Name]--data PostScopeState = PostScopeState-  { stPostSyntaxInfo          :: !CompressedFile-    -- ^ Highlighting info.-  , stPostDisambiguatedNames  :: !DisambiguatedNames-    -- ^ Disambiguation carried out by the type checker.-    --   Maps position of first name character to disambiguated @'A.QName'@-    --   for each @'A.AmbiguousQName'@ already passed by the type checker.-  , stPostMetaStore           :: !MetaStore-  , stPostInteractionPoints   :: !InteractionPoints -- scope checker first-  , stPostAwakeConstraints    :: !Constraints-  , stPostSleepingConstraints :: !Constraints-  , stPostDirty               :: !Bool -- local-    -- ^ Dirty when a constraint is added, used to prevent pointer update.-    -- Currently unused.-  , stPostOccursCheckDefs     :: !(Set QName) -- local-    -- ^ Definitions to be considered during occurs check.-    --   Initialized to the current mutual block before the check.-    --   During occurs check, we remove definitions from this set-    --   as soon we have checked them.-  , stPostSignature           :: !Signature-    -- ^ Declared identifiers of the current file.-    --   These will be serialized after successful type checking.-  , stPostModuleCheckpoints   :: !(Map ModuleName CheckpointId)-    -- ^ For each module remember the checkpoint corresponding to the orignal-    --   context of the module parameters.-  , stPostImportsDisplayForms :: !DisplayForms-    -- ^ Display forms we add for imported identifiers-  , stPostCurrentModule       :: !(Strict.Maybe ModuleName)-    -- ^ The current module is available after it has been type-    -- checked.-  , stPostInstanceDefs        :: !TempInstanceTable-  , stPostConcreteNames       :: !ConcreteNames-    -- ^ Map keeping track of concrete names assigned to each abstract name-    --   (can be more than one name in case the first one is shadowed)-  , stPostUsedNames           :: !(Map RawName [RawName])-    -- ^ Map keeping track for each name root (= name w/o numeric-    -- suffixes) what names with the same root have been used during a-    -- TC computation. This information is used to build the-    -- @ShadowingNames@ map.-  , stPostShadowingNames      :: !(Map Name [RawName])-    -- ^ Map keeping track for each (abstract) name the list of all-    -- (raw) names that it could maybe be shadowed by.-  , stPostStatistics          :: !Statistics-    -- ^ Counters to collect various statistics about meta variables etc.-    --   Only for current file.-  , stPostTCWarnings          :: ![TCWarning]-  , stPostMutualBlocks        :: !(Map MutualId MutualBlock)-  , stPostLocalBuiltins       :: !(BuiltinThings PrimFun)-  , stPostFreshMetaId         :: !MetaId-  , stPostFreshMutualId       :: !MutualId-  , stPostFreshProblemId      :: !ProblemId-  , stPostFreshCheckpointId   :: !CheckpointId-  , stPostFreshInt            :: !Int-  , stPostFreshNameId         :: !NameId-  , stPostAreWeCaching        :: !Bool-  , stPostPostponeInstanceSearch :: !Bool-  , stPostConsideringInstance :: !Bool-  , stPostInstantiateBlocking :: !Bool-    -- ^ Should we instantiate away blocking metas?-    --   This can produce ill-typed terms but they are often more readable. See issue #3606.-    --   Best set to True only for calls to pretty*/reify to limit unwanted reductions.-  , stPostLocalPartialDefs    :: !(Set QName)-    -- ^ Local partial definitions, to be stored in the @Interface@-  }---- | A mutual block of names in the signature.-data MutualBlock = MutualBlock-  { mutualInfo  :: Info.MutualInfo-    -- ^ The original info of the mutual block.-  , mutualNames :: Set QName-  } deriving (Show, Eq)--instance Null MutualBlock where-  empty = MutualBlock empty empty---- | A part of the state which is not reverted when an error is thrown--- or the state is reset.-data PersistentTCState = PersistentTCSt-  { stDecodedModules    :: DecodedModules-  , stPersistentOptions :: CommandLineOptions-  , stInteractionOutputCallback  :: InteractionOutputCallback-    -- ^ Callback function to call when there is a response-    --   to give to the interactive frontend.-    --   See the documentation of 'InteractionOutputCallback'.-  , stBenchmark         :: !Benchmark-    -- ^ Structure to track how much CPU time was spent on which Agda phase.-    --   Needs to be a strict field to avoid space leaks!-  , stAccumStatistics   :: !Statistics-    -- ^ Should be strict field.-  , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)-    -- ^ Cached typechecking state from the last loaded file.-    --   Should be @Nothing@ when checking imports.-  , stPersistBackends   :: [Backend]-    -- ^ Current backends with their options-  }--data LoadedFileCache = LoadedFileCache-  { lfcCached  :: !CachedTypeCheckLog-  , lfcCurrent :: !CurrentTypeCheckLog-  }---- | 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 !Info.ModuleInfo !ModuleName !A.Telescope-  | LeaveSection !ModuleName-  | Decl !A.Declaration-    -- ^ Never a Section or ScopeDecl-  | Pragmas !PragmaOptions---- | Empty persistent state.--initPersistentState :: PersistentTCState-initPersistentState = PersistentTCSt-  { stPersistentOptions         = defaultOptions-  , stDecodedModules            = Map.empty-  , stInteractionOutputCallback = defaultInteractionOutputCallback-  , stBenchmark                 = empty-  , stAccumStatistics           = Map.empty-  , stPersistLoadedFileCache    = empty-  , stPersistBackends           = []-  }---- | Empty state of type checker.--initPreScopeState :: PreScopeState-initPreScopeState = PreScopeState-  { stPreTokens               = mempty-  , stPreImports              = emptySignature-  , stPreImportedModules      = Set.empty-  , stPreModuleToSource       = Map.empty-  , stPreVisitedModules       = Map.empty-  , stPreScope                = emptyScopeInfo-  , stPrePatternSyns          = Map.empty-  , stPrePatternSynImports    = Map.empty-  , stPreGeneralizedVars      = mempty-  , stPrePragmaOptions        = defaultInteractionOptions-  , stPreImportedBuiltins     = Map.empty-  , stPreImportedDisplayForms = HMap.empty-  , stPreImportedInstanceDefs = Map.empty-  , stPreForeignCode          = Map.empty-  , stPreFreshInteractionId   = 0-  , stPreImportedUserWarnings = Map.empty-  , stPreLocalUserWarnings    = Map.empty-  , stPreWarningOnImport      = empty-  , stPreImportedPartialDefs  = Set.empty-  }--initPostScopeState :: PostScopeState-initPostScopeState = PostScopeState-  { stPostSyntaxInfo           = mempty-  , stPostDisambiguatedNames   = IntMap.empty-  , stPostMetaStore            = IntMap.empty-  , stPostInteractionPoints    = Map.empty-  , stPostAwakeConstraints     = []-  , stPostSleepingConstraints  = []-  , stPostDirty                = False-  , stPostOccursCheckDefs      = Set.empty-  , stPostSignature            = emptySignature-  , stPostModuleCheckpoints    = Map.empty-  , stPostImportsDisplayForms  = HMap.empty-  , stPostCurrentModule        = empty-  , stPostInstanceDefs         = (Map.empty , Set.empty)-  , stPostConcreteNames        = Map.empty-  , stPostUsedNames            = Map.empty-  , stPostShadowingNames       = Map.empty-  , stPostStatistics           = Map.empty-  , stPostTCWarnings           = []-  , stPostMutualBlocks         = Map.empty-  , stPostLocalBuiltins        = Map.empty-  , stPostFreshMetaId          = 0-  , stPostFreshMutualId        = 0-  , stPostFreshProblemId       = 1-  , stPostFreshCheckpointId    = 1-  , stPostFreshInt             = 0-  , stPostFreshNameId           = NameId 0 0-  , stPostAreWeCaching         = False-  , stPostPostponeInstanceSearch = False-  , stPostConsideringInstance  = False-  , stPostInstantiateBlocking  = False-  , stPostLocalPartialDefs     = Set.empty-  }--initState :: TCState-initState = TCSt-  { stPreScopeState   = initPreScopeState-  , stPostScopeState  = initPostScopeState-  , stPersistentState = initPersistentState-  }---- * st-prefixed lenses---------------------------------------------------------------------------stTokens :: Lens' CompressedFile TCState-stTokens f s =-  f (stPreTokens (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}}--stImports :: Lens' Signature TCState-stImports f s =-  f (stPreImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}}--stImportedModules :: Lens' (Set ModuleName) TCState-stImportedModules f s =-  f (stPreImportedModules (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}}--stModuleToSource :: Lens' ModuleToSource TCState-stModuleToSource f s =-  f (stPreModuleToSource (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}}--stVisitedModules :: Lens' VisitedModules TCState-stVisitedModules f s =-  f (stPreVisitedModules (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}}--stScope :: Lens' ScopeInfo TCState-stScope f s =-  f (stPreScope (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}}--stPatternSyns :: Lens' A.PatternSynDefns TCState-stPatternSyns f s =-  f (stPrePatternSyns (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}}--stPatternSynImports :: Lens' A.PatternSynDefns TCState-stPatternSynImports f s =-  f (stPrePatternSynImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}}--stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState-stGeneralizedVars f s =-  f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}}--stPragmaOptions :: Lens' PragmaOptions TCState-stPragmaOptions f s =-  f (stPrePragmaOptions (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}}--stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState-stImportedBuiltins f s =-  f (stPreImportedBuiltins (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}}--stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState-stForeignCode f s =-  f (stPreForeignCode (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}}--stFreshInteractionId :: Lens' InteractionId TCState-stFreshInteractionId f s =-  f (stPreFreshInteractionId (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}--stImportedUserWarnings :: Lens' (Map A.QName String) TCState-stImportedUserWarnings f s =-  f (stPreImportedUserWarnings (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}}--stLocalUserWarnings :: Lens' (Map A.QName String) TCState-stLocalUserWarnings f s =-  f (stPreLocalUserWarnings (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}}--getUserWarnings :: ReadTCState m => m (Map A.QName String)-getUserWarnings = do-  iuw <- useR stImportedUserWarnings-  luw <- useR stLocalUserWarnings-  return $ iuw `Map.union` luw--stWarningOnImport :: Lens' (Maybe String) TCState-stWarningOnImport f s =-  f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}}--stImportedPartialDefs :: Lens' (Set QName) TCState-stImportedPartialDefs f s =-  f (stPreImportedPartialDefs (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}}--stLocalPartialDefs :: Lens' (Set QName) TCState-stLocalPartialDefs f s =-  f (stPostLocalPartialDefs (stPostScopeState s)) <&>-  \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}}--getPartialDefs :: ReadTCState m => m (Set QName)-getPartialDefs = do-  ipd <- useR stImportedPartialDefs-  lpd <- useR stLocalPartialDefs-  return $ ipd `Set.union` lpd--stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState-stLoadedFileCache f s =-  f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&>-  \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}}--stBackends :: Lens' [Backend] TCState-stBackends f s =-  f (stPersistBackends (stPersistentState s)) <&>-  \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}}--stFreshNameId :: Lens' NameId TCState-stFreshNameId f s =-  f (stPostFreshNameId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}}--stSyntaxInfo :: Lens' CompressedFile TCState-stSyntaxInfo f s =-  f (stPostSyntaxInfo (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}}--stDisambiguatedNames :: Lens' DisambiguatedNames TCState-stDisambiguatedNames f s =-  f (stPostDisambiguatedNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}}--stMetaStore :: Lens' MetaStore TCState-stMetaStore f s =-  f (stPostMetaStore (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMetaStore = x}}--stInteractionPoints :: Lens' InteractionPoints TCState-stInteractionPoints f s =-  f (stPostInteractionPoints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}--stAwakeConstraints :: Lens' Constraints TCState-stAwakeConstraints f s =-  f (stPostAwakeConstraints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}}--stSleepingConstraints :: Lens' Constraints TCState-stSleepingConstraints f s =-  f (stPostSleepingConstraints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}}--stDirty :: Lens' Bool TCState-stDirty f s =-  f (stPostDirty (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}}--stOccursCheckDefs :: Lens' (Set QName) TCState-stOccursCheckDefs f s =-  f (stPostOccursCheckDefs (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}}--stSignature :: Lens' Signature TCState-stSignature f s =-  f (stPostSignature (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}}--stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState-stModuleCheckpoints f s =-  f (stPostModuleCheckpoints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}}--stImportsDisplayForms :: Lens' DisplayForms TCState-stImportsDisplayForms f s =-  f (stPostImportsDisplayForms (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}}--stImportedDisplayForms :: Lens' DisplayForms TCState-stImportedDisplayForms f s =-  f (stPreImportedDisplayForms (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}}--stCurrentModule :: Lens' (Maybe ModuleName) TCState-stCurrentModule f s =-  f (Strict.toLazy $ stPostCurrentModule (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = Strict.toStrict x}}--stImportedInstanceDefs :: Lens' InstanceTable TCState-stImportedInstanceDefs f s =-  f (stPreImportedInstanceDefs (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}}--stInstanceDefs :: Lens' TempInstanceTable TCState-stInstanceDefs f s =-  f (stPostInstanceDefs (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}}--stConcreteNames :: Lens' ConcreteNames TCState-stConcreteNames f s =-  f (stPostConcreteNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}}--stUsedNames :: Lens' (Map RawName [RawName]) TCState-stUsedNames f s =-  f (stPostUsedNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}}--stShadowingNames :: Lens' (Map Name [RawName]) TCState-stShadowingNames f s =-  f (stPostShadowingNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}}--stStatistics :: Lens' Statistics TCState-stStatistics f s =-  f (stPostStatistics (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}--stTCWarnings :: Lens' [TCWarning] TCState-stTCWarnings f s =-  f (stPostTCWarnings (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}}--stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState-stMutualBlocks f s =-  f (stPostMutualBlocks (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}--stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState-stLocalBuiltins f s =-  f (stPostLocalBuiltins (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}}--stFreshMetaId :: Lens' MetaId TCState-stFreshMetaId f s =-  f (stPostFreshMetaId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}}--stFreshMutualId :: Lens' MutualId TCState-stFreshMutualId f s =-  f (stPostFreshMutualId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}}--stFreshProblemId :: Lens' ProblemId TCState-stFreshProblemId f s =-  f (stPostFreshProblemId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}--stFreshCheckpointId :: Lens' CheckpointId TCState-stFreshCheckpointId f s =-  f (stPostFreshCheckpointId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}}--stFreshInt :: Lens' Int TCState-stFreshInt f s =-  f (stPostFreshInt (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}}---- use @areWeCaching@ from the Caching module instead.-stAreWeCaching :: Lens' Bool TCState-stAreWeCaching f s =-  f (stPostAreWeCaching (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}}--stPostponeInstanceSearch :: Lens' Bool TCState-stPostponeInstanceSearch f s =-  f (stPostPostponeInstanceSearch (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}}--stConsideringInstance :: Lens' Bool TCState-stConsideringInstance f s =-  f (stPostConsideringInstance (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}}--stInstantiateBlocking :: Lens' Bool TCState-stInstantiateBlocking f s =-  f (stPostInstantiateBlocking (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}}--stBuiltinThings :: TCState -> BuiltinThings PrimFun-stBuiltinThings s = (s^.stLocalBuiltins) `Map.union` (s^.stImportedBuiltins)----- * Fresh things---------------------------------------------------------------------------class Enum i => HasFresh i where-    freshLens :: Lens' i TCState-    nextFresh' :: i -> i-    nextFresh' = succ--nextFresh :: HasFresh i => TCState -> (i, TCState)-nextFresh s =-  let !c = s^.freshLens-  in (c, set freshLens (nextFresh' c) s)--class Monad m => MonadFresh i m where-  fresh :: m i--instance MonadFresh i m => MonadFresh i (ReaderT r m) where-  fresh = lift fresh--instance MonadFresh i m => MonadFresh i (StateT s m) where-  fresh = lift fresh--instance HasFresh i => MonadFresh i TCM where-  fresh = do-        !s <- getTC-        let (!c , !s') = nextFresh s-        putTC s'-        return c--instance HasFresh MetaId where-  freshLens = stFreshMetaId--instance HasFresh MutualId where-  freshLens = stFreshMutualId--instance HasFresh InteractionId where-  freshLens = stFreshInteractionId--instance HasFresh NameId where-  freshLens = stFreshNameId-  -- nextFresh increments the current fresh name by 2 so @NameId@s used-  -- before caching starts do not overlap with the ones used after.-  nextFresh' = succ . succ--instance HasFresh Int where-  freshLens = stFreshInt--newtype ProblemId = ProblemId Nat-  deriving (Data, Eq, Ord, Enum, Real, Integral, Num)---- TODO: 'Show' should output Haskell-parseable representations.--- The following instance is deprecated, and Pretty[TCM] should be used--- instead. Later, simply derive Show for this type.---- ASR (28 December 2014). This instance is not used anymore (module--- the test suite) when reporting errors. See Issue 1293.---- This particular Show instance is ok because of the Num instance.-instance Show ProblemId where-  show (ProblemId n) = show n--instance Pretty ProblemId where-  pretty (ProblemId n) = pretty n--instance HasFresh ProblemId where-  freshLens = stFreshProblemId--newtype CheckpointId = CheckpointId Int-  deriving (Data, Eq, Ord, Enum, Real, Integral, Num)--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 $ Name 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 $ Name i (C.Name noRange C.NotInScope [C.Id "r"]) noRange noFixity' True---- | Create a fresh name from @a@.-class FreshName a where-  freshName_ :: MonadFresh NameId m => a -> m Name--instance FreshName (Range, String) where-  freshName_ = uncurry freshName--instance FreshName String where-  freshName_ = freshName noRange--instance FreshName Range where-  freshName_ = freshNoName--instance FreshName () where-  freshName_ () = freshNoName_-------------------------------------------------------------------------------- ** Managing file names-------------------------------------------------------------------------------- | Maps top-level module names to the corresponding source file--- names.--type ModuleToSource = Map TopLevelModuleName AbsolutePath---- | Maps source file names to the corresponding top-level module--- names.--type SourceToModule = Map AbsolutePath TopLevelModuleName---- | Creates a 'SourceToModule' map based on 'stModuleToSource'.------   O(n log n).------   For a single reverse lookup in 'stModuleToSource',---   rather use 'lookupModuleFromSourse'.--sourceToModule :: TCM SourceToModule-sourceToModule =-  Map.fromList-     .  List.map (\(m, f) -> (f, m))-     .  Map.toList-    <$> useTC stModuleToSource---- | Lookup an 'AbsolutePath' in 'sourceToModule'.------   O(n).--lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName)-lookupModuleFromSource f =-  fmap fst . List.find ((f ==) . snd) . Map.toList <$> useR stModuleToSource--------------------------------------------------------------------------------- ** Associating concrete names to an abstract name-------------------------------------------------------------------------------- | A monad that has read and write access to the stConcreteNames---   part of the TCState. Basically, this is a synonym for `MonadState---   ConcreteNames m` (which cannot be used directly because of the---   limitations of Haskell's typeclass system).-class Monad m => MonadStConcreteNames m where-  runStConcreteNames :: StateT ConcreteNames m a -> m a--  useConcreteNames :: m ConcreteNames-  useConcreteNames = runStConcreteNames get--  modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m ()-  modifyConcreteNames = runStConcreteNames . modify--instance MonadStConcreteNames TCM where-  runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m--instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where-  runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . (flip $ runReaderT . runStateT m)--instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where-  runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do-    ((x,ns'),s') <- runStateT (runStateT m ns) s-    return ((x,s'),ns')-------------------------------------------------------------------------------- ** Interface------------------------------------------------------------------------------data ModuleInfo = ModuleInfo-  { miInterface  :: Interface-  , miWarnings   :: Bool-    -- ^ 'True' if warnings were encountered when the module was type-    -- checked.-  , miPrimitive  :: Bool-    -- ^ 'True' if the module is a primitive module, which should always-    -- be importable.-  }---- Note that the use of 'C.TopLevelModuleName' here is a potential--- performance problem, because these names do not contain unique--- identifiers.--type VisitedModules = Map C.TopLevelModuleName ModuleInfo-type DecodedModules = Map C.TopLevelModuleName Interface--data ForeignCode = ForeignCode Range String-  deriving Show--data Interface = Interface-  { iSourceHash      :: Hash-    -- ^ Hash of the source code.-  , iSource          :: Text-    -- ^ The source code. The source code is stored so that the HTML-    -- and LaTeX backends can generate their output without having to-    -- re-read the (possibly out of date) source code.-  , iFileType        :: FileType-    -- ^ Source file type, determined from the file extension-  , iImportedModules :: [(ModuleName, Hash)]-    -- ^ Imported modules and their hashes.-  , iModuleName      :: ModuleName-    -- ^ Module name of this interface.-  , iScope           :: Map ModuleName Scope-    -- ^ Scope defined by this module.-    ---    --   Andreas, AIM XX: Too avoid duplicate serialization, this field is-    --   not serialized, so if you deserialize an interface, @iScope@-    --   will be empty.-    --   But 'constructIScope' constructs 'iScope' from 'iInsideScope'.-  , iInsideScope     :: ScopeInfo-    -- ^ Scope after we loaded this interface.-    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'-    --   and     'Agda.Interaction.CommandLine.interactionLoop'.-  , iSignature       :: Signature-  , iDisplayForms    :: DisplayForms-    -- ^ Display forms added for imported identifiers.-  , iUserWarnings    :: Map A.QName String-    -- ^ User warnings for imported identifiers-  , iImportWarning   :: Maybe String-    -- ^ Whether this module should raise a warning when imported-  , iBuiltin         :: BuiltinThings (String, QName)-  , iForeignCode     :: Map BackendName [ForeignCode]-  , iHighlighting    :: HighlightingInfo-  , iPragmaOptions   :: [OptionsPragma]-    -- ^ Pragma options set in the file.-  , iOptionsUsed     :: PragmaOptions-    -- ^ Options/features used when checking the file (can be different-    --   from options set directly in the file).-  , iPatternSyns     :: A.PatternSynDefns-  , iWarnings        :: [TCWarning]-  , iPartialDefs     :: Set QName-  }-  deriving Show--instance Pretty Interface where-  pretty (Interface-            sourceH source fileT importedM moduleN scope insideS signature-            display userwarn importwarn builtin foreignCode highlighting pragmaO-            oUsed patternS warnings partialdefs) =--    hang "Interface" 2 $ vcat-      [ "source hash:"         <+> (pretty . show) sourceH-      , "source:"              $$  nest 2 (text $ T.unpack source)-      , "file type:"           <+> (pretty . show) fileT-      , "imported modules:"    <+> (pretty . show) importedM-      , "module name:"         <+> pretty moduleN-      , "scope:"               <+> (pretty . show) scope-      , "inside scope:"        <+> (pretty . show) insideS-      , "signature:"           <+> (pretty . show) signature-      , "display:"             <+> (pretty . show) display-      , "user warnings:"       <+> (pretty . show) userwarn-      , "import warning:"      <+> (pretty . show) importwarn-      , "builtin:"             <+> (pretty . show) builtin-      , "Foreign code:"        <+> (pretty . show) foreignCode-      , "highlighting:"        <+> (pretty . show) highlighting-      , "pragma options:"      <+> (pretty . show) pragmaO-      , "options used:"        <+> (pretty . show) oUsed-      , "pattern syns:"        <+> (pretty . show) patternS-      , "warnings:"            <+> (pretty . show) warnings-      , "partial definitions:" <+> (pretty . show) partialdefs-      ]---- | Combines the source hash and the (full) hashes of the imported modules.-iFullHash :: Interface -> Hash-iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)-------------------------------------------------------------------------------- ** Closure------------------------------------------------------------------------------data Closure a = Closure-  { clSignature        :: Signature-  , clEnv              :: TCEnv-  , clScope            :: ScopeInfo-  , clModuleCheckpoints :: Map ModuleName CheckpointId-  , clValue            :: a-  }-    deriving (Data, Functor, Foldable)--instance Show a => Show (Closure a) where-  show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }"--instance HasRange a => HasRange (Closure a) where-  getRange = getRange . clValue--class LensClosure a b | b -> a where-  lensClosure :: Lens' (Closure a) b--instance LensClosure a (Closure a) where-  lensClosure = id--instance LensTCEnv (Closure a) where-  lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }--buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a)-buildClosure x = do-    env   <- askTC-    sig   <- useR stSignature-    scope <- useR stScope-    cps   <- useR stModuleCheckpoints-    return $ Closure sig env scope cps x-------------------------------------------------------------------------------- ** Constraints------------------------------------------------------------------------------type Constraints = [ProblemConstraint]--data ProblemConstraint = PConstr-  { constraintProblems :: Set ProblemId-  , theConstraint      :: Closure Constraint-  }-  deriving (Data, Show)--instance HasRange ProblemConstraint where-  getRange = getRange . theConstraint--data Constraint-  = ValueCmp Comparison CompareAs Term Term-  | ValueCmpOnFace Comparison Term Type Term Term-  | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim]-  | TelCmp Type Type Comparison Telescope Telescope -- ^ the two types are for the error message only-  | SortCmp Comparison Sort Sort-  | LevelCmp Comparison Level Level---  | ShortCut MetaId Term Type---    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.-  | HasBiggerSort Sort-  | HasPTSRule (Dom Type) (Abs Sort)-  | CheckMetaInst MetaId-  | UnBlock MetaId-  | Guarded Constraint ProblemId-  | IsEmpty Range Type-    -- ^ The range is the one of the absurd pattern.-  | CheckSizeLtSat Term-    -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT.-  | FindInstance MetaId (Maybe MetaId) (Maybe [Candidate])-    -- ^ the first argument is the instance argument, the second one is the meta-    --   on which the constraint may be blocked on and the third one is the list-    --   of candidates (or Nothing if we haven’t determined the list of-    --   candidates yet)-  | CheckFunDef Delayed A.DefInfo QName [A.Clause]-  | UnquoteTactic (Maybe MetaId) Term Term Type   -- ^ First argument is computation and the others are hole and goal type-  deriving (Data, Show)--instance HasRange Constraint where-  getRange (IsEmpty r t) = r-  getRange _ = noRange-{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId-  getRange (ValueCmp cmp a u v) = getRange (a,u,v)-  getRange (ElimCmp pol a v es es') = getRange (a,v,es,es')-  getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel')-  getRange (SortCmp cmp s s') = getRange (s,s')-  getRange (LevelCmp cmp l l') = getRange (l,l')-  getRange (UnBlock x) = getRange x-  getRange (Guarded c pid) = getRange c-  getRange (FindInstance x cands) = getRange x--}--instance Free Constraint where-  freeVars' c =-    case c of-      ValueCmp _ t u v      -> freeVars' (t, (u, v))-      ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v)))-      ElimCmp _ _ t u es es'  -> freeVars' ((t, u), (es, es'))-      TelCmp _ _ _ tel tel' -> freeVars' (tel, tel')-      SortCmp _ s s'        -> freeVars' (s, s')-      LevelCmp _ l l'       -> freeVars' (l, l')-      UnBlock _             -> mempty-      Guarded c _           -> freeVars' c-      IsEmpty _ t           -> freeVars' t-      CheckSizeLtSat u      -> freeVars' u-      FindInstance _ _ cs   -> freeVars' cs-      CheckFunDef _ _ _ _   -> mempty-      HasBiggerSort s       -> freeVars' s-      HasPTSRule a s        -> freeVars' (a , s)-      UnquoteTactic _ t h g -> freeVars' (t, (h, g))-      CheckMetaInst m       -> mempty--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')-      IsEmpty _ t            -> foldTerm f t-      CheckSizeLtSat u       -> foldTerm f u-      UnquoteTactic _ t h g  -> foldTerm f (t, h, g)-      Guarded c _            -> foldTerm f c-      TelCmp _ _ _ tel1 tel2 -> foldTerm f (tel1, tel2)-      SortCmp _ s1 s2        -> foldTerm f (Sort s1, Sort s2)-      UnBlock _              -> mempty-      FindInstance _ _ _     -> mempty-      CheckFunDef _ _ _ _    -> mempty-      HasBiggerSort s        -> foldTerm f s-      HasPTSRule a s         -> foldTerm f (a, Sort <$> s)-      CheckMetaInst m        -> mempty-  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented---data Comparison = CmpEq | CmpLeq-  deriving (Eq, Data, Show)--instance Pretty Comparison where-  pretty CmpEq  = "="-  pretty CmpLeq = "=<"---- | An extension of 'Comparison' to @>=@.-data CompareDirection = DirEq | DirLeq | DirGeq-  deriving (Eq, Show)--instance Pretty CompareDirection where-  pretty = text . \case-    DirEq  -> "="-    DirLeq -> "=<"-    DirGeq -> ">="---- | Embed 'Comparison' into 'CompareDirection'.-fromCmp :: Comparison -> CompareDirection-fromCmp CmpEq  = DirEq-fromCmp CmpLeq = DirLeq---- | Flip the direction of comparison.-flipCmp :: CompareDirection -> CompareDirection-flipCmp DirEq  = DirEq-flipCmp DirLeq = DirGeq-flipCmp DirGeq = DirLeq---- | Turn a 'Comparison' function into a 'CompareDirection' function.------   Property: @dirToCmp f (fromCmp cmp) = f cmp@-dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c-dirToCmp cont DirEq  = cont CmpEq-dirToCmp cont DirLeq = cont CmpLeq-dirToCmp cont DirGeq = flip $ cont CmpLeq---- | We can either compare two terms at a given type, or compare two---   types without knowing (or caring about) their sorts.-data CompareAs-  = AsTermsOf Type -- ^ @Type@ should not be @Size@.-                   --   But currently, we do not rely on this invariant.-  | AsSizes        -- ^ Replaces @AsTermsOf Size@.-  | AsTypes-  deriving (Data, Show)--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-------------------------------------------------------------------------------- * Open things-------------------------------------------------------------------------------- | A thing tagged with the context it came from.-data Open a = OpenThing { openThingCheckpoint :: CheckpointId, openThing :: a }-    deriving (Data, Show, Functor, Foldable, Traversable)--instance Decoration Open where-  traverseF f (OpenThing cp x) = OpenThing cp <$> f 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-    }--instance Show a => Show (Judgement a) where-    show (HasType a cmp t) = show a ++ " : " ++ show t-    show (IsSort  a t) = show a ++ " :sort " ++ show t---------------------------------------------------------------------------------- ** Generalizable variables--------------------------------------------------------------------------------data DoGeneralize = YesGeneralize | NoGeneralize-  deriving (Eq, Ord, Show, Data)---- | The value of a generalizable variable. This is created to be a---   generalizable meta before checking the type to be generalized.-data GeneralizedValue = GeneralizedValue-  { genvalCheckpoint :: CheckpointId-  , genvalTerm       :: Term-  , genvalType       :: Type-  } deriving (Show, Data)-------------------------------------------------------------------------------- ** 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 this meta will be equated to @m@ when the latter is unblocked. See @blockedTermOnProblem@.-                }--data Listener = EtaExpand MetaId-              | CheckConstraint Nat ProblemConstraint--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)--data MetaInstantiation-        = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)-        | Open               -- ^ unsolved-        | OpenInstance       -- ^ open, to be instantiated by instance search-        | BlockedConst Term  -- ^ solution blocked by unsolved constraints-        | PostponedTypeCheckingProblem (Closure TypeCheckingProblem) (TCM Bool)---- | 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 TypeCheckingProblem-  = CheckExpr Comparison A.Expr Type-  | CheckArgs ExpandHidden Range [NamedArg A.Expr] Type Type ([Maybe Range] -> Elims -> Type -> CheckedTarget -> TCM Term)-  | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (NonEmpty QName) A.Args Type Int Term Type-  | CheckLambda Comparison (Arg ([WithHiding Name], Maybe Type)) A.Expr Type-    -- ^ @(λ (xs : t₀) → e) : t@-    --   This is not an instance of 'CheckExpr' as the domain type-    --   has already been checked.-    --   For example, when checking-    --     @(λ (x y : Fin _) → e) : (x : Fin n) → ?@-    --   we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@-    --   is a 'Type' rather than an 'A.Expr'.-  | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`--instance Show MetaInstantiation where-  show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"-  show Open      = "Open"-  show OpenInstance = "OpenInstance"-  show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")"-  show (PostponedTypeCheckingProblem{}) = "PostponedTypeCheckingProblem (...)"---- | Meta variable priority:---   When we have an equation between meta-variables, which one---   should be instantiated?------   Higher value means higher priority to be instantiated.-newtype MetaPriority = MetaPriority Int-    deriving (Eq , Ord , Show)--data RunMetaOccursCheck-  = RunMetaOccursCheck-  | DontRunMetaOccursCheck-  deriving (Eq , Ord , Show)---- | @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.---  , miRelevance       :: Relevance          -- ^ Created in irrelevant position?-  , 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?-  }---- | Name suggestion for meta variable.  Empty string means no suggestion.-type MetaNameSuggestion = String---- | For printing, we couple a meta with its name suggestion.-data NamedMeta = NamedMeta-  { nmSuggestion :: MetaNameSuggestion-  , nmid         :: MetaId-  }--instance Pretty NamedMeta where-  pretty (NamedMeta "" x) = pretty x-  pretty (NamedMeta "_" x) = pretty x-  pretty (NamedMeta s  x) = text $ "_" ++ s ++ prettyShow x--type MetaStore = IntMap MetaVariable--instance HasRange MetaInfo where-  getRange = clValue . miClosRange--instance HasRange MetaVariable where-    getRange m = getRange $ getMetaInfo m--instance SetRange MetaInfo where-  setRange r m = m { miClosRange = (miClosRange m) { clValue = r }}--instance SetRange MetaVariable where-  setRange r m = m { mvInfo = setRange r (mvInfo m) }--normalMetaPriority :: MetaPriority-normalMetaPriority = MetaPriority 0--lowMetaPriority :: MetaPriority-lowMetaPriority = MetaPriority (-10)--highMetaPriority :: MetaPriority-highMetaPriority = MetaPriority 10--getMetaInfo :: MetaVariable -> Closure Range-getMetaInfo = miClosRange . mvInfo--getMetaScope :: MetaVariable -> ScopeInfo-getMetaScope m = clScope $ getMetaInfo m--getMetaEnv :: MetaVariable -> TCEnv-getMetaEnv m = clEnv $ getMetaInfo m--getMetaSig :: MetaVariable -> Signature-getMetaSig m = clSignature $ getMetaInfo m--getMetaRelevance :: MetaVariable -> Relevance-getMetaRelevance = getRelevance . getMetaEnv--getMetaModality :: MetaVariable -> Modality--- Andrea 23/02/2020: use getModality to enforce invariants of the---                    envModality field.-getMetaModality = getModality . getMetaEnv---- Lenses--metaFrozen :: Lens' Frozen MetaVariable-metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }--_mvInfo :: Lens' MetaInfo MetaVariable-_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }---- Lenses onto Closure Range--instance LensClosure Range MetaInfo where-  lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }--instance LensClosure Range MetaVariable where-  lensClosure = _mvInfo . lensClosure---- Lenses onto IsAbstract--instance LensIsAbstract TCEnv where-  lensIsAbstract f env =-     -- Andreas, 2019-08-19-     -- Using $! to prevent space leaks like #1829.-     -- This can crash when trying to get IsAbstract from IgnoreAbstractMode.-    (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env))-    <&> \ a -> env { envAbstractMode = aDefToMode a }--instance LensIsAbstract (Closure a) where-  lensIsAbstract = lensTCEnv . lensIsAbstract--instance LensIsAbstract MetaInfo where-  lensIsAbstract = lensClosure . lensIsAbstract-------------------------------------------------------------------------------- ** Interaction meta variables-------------------------------------------------------------------------------- | Interaction points are created by the scope checker who sets the range.---   The meta variable is created by the type checker and then hooked up to the---   interaction point.-data InteractionPoint = InteractionPoint-  { ipRange :: Range        -- ^ The position of the interaction point.-  , ipMeta  :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.-  , ipSolved:: Bool         -- ^ Has this interaction point already been solved?-  , ipClause:: IPClause-      -- ^ The clause of the interaction point (if any).-      --   Used for case splitting.-  }--instance Eq InteractionPoint where (==) = (==) `on` 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 = Map InteractionId InteractionPoint----- | Flag to indicate whether the meta is overapplied in the---   constraint.  A meta is overapplied if it has more arguments than---   the size of the telescope in its creation environment---   (as stored in MetaInfo).-data Overapplied = Overapplied | NotOverapplied deriving (Eq, Show, Data)---- | Datatype representing a single boundary condition:---   x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es-data IPBoundary' t = IPBoundary-  { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n]-  , ipbValue     :: t          -- ^ @t@-  , ipbMetaApp   :: t          -- ^ @?n es@-  , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ?-  }-  deriving (Show, Data, Functor, Foldable, Traversable)--type IPBoundary = IPBoundary' Term---- | Which clause is an interaction point located in?-data IPClause = IPClause-  { ipcQName    :: QName              -- ^ The name of the function.-  , ipcClauseNo :: Int                -- ^ The number of the clause of this function.-  , ipcType     :: Type               -- ^ The type of the function-  , ipcWithSub  :: Maybe Substitution -- ^ Module parameter substitution-  , ipcClause   :: A.SpineClause      -- ^ The original AST clause.-  , ipcClosure  :: Closure ()         -- ^ Environment for rechecking the clause.-  , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS.-  }-  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.-  deriving (Data)--instance Eq IPClause where-  IPNoClause           == IPNoClause             = True-  IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i'-  _                    == _                      = False-------------------------------------------------------------------------------- ** Signature------------------------------------------------------------------------------data Signature = Sig-      { _sigSections    :: Sections-      , _sigDefinitions :: Definitions-      , _sigRewriteRules:: RewriteRuleMap  -- ^ The rewrite rules defined in this file.-      }-  deriving (Data, Show)--sigSections :: Lens' Sections Signature-sigSections f s =-  f (_sigSections s) <&>-  \x -> s {_sigSections = x}--sigDefinitions :: Lens' Definitions Signature-sigDefinitions f s =-  f (_sigDefinitions s) <&>-  \x -> s {_sigDefinitions = x}--sigRewriteRules :: Lens' RewriteRuleMap Signature-sigRewriteRules f s =-  f (_sigRewriteRules s) <&>-  \x -> s {_sigRewriteRules = x}--type Sections    = Map ModuleName Section-type Definitions = HashMap QName Definition-type RewriteRuleMap = HashMap QName RewriteRules-type DisplayForms = HashMap QName [LocalDisplayForm]--newtype Section = Section { _secTelescope :: Telescope }-  deriving (Data, Show)--instance Pretty Section where-  pretty = pretty . _secTelescope--secTelescope :: Lens' Telescope Section-secTelescope f s =-  f (_secTelescope s) <&>-  \x -> s {_secTelescope = x}--emptySignature :: Signature-emptySignature = Sig Map.empty HMap.empty HMap.empty---- | A @DisplayForm@ is in essence a rewrite rule---   @---      q ts --> dt---   @---   for a defined symbol (could be a constructor as well) @q@.---   The right hand side is a 'DisplayTerm' which is used to---   'reify' to a more readable 'Abstract.Syntax'.------   The patterns @ts@ are just terms, but @var 0@ is interpreted---   as a hole.  Each occurrence of @var 0@ is a new hole (pattern var).---   For each *occurrence* of @var0@ the rhs @dt@ has a free variable.---   These are instantiated when matching a display form against a---   term @q vs@ succeeds.-data DisplayForm = Display-  { dfFreeVars :: Nat-    -- ^ Number @n@ of free variables in 'dfRHS'.-  , dfPats     :: Elims-    -- ^ Left hand side patterns, where @var 0@ stands for a pattern-    --   variable.  There should be @n@ occurrences of @var0@ in-    --   'dfPats'.-    --   The 'ArgInfo' is ignored in these patterns.-  , dfRHS      :: DisplayTerm-    -- ^ Right hand side, with @n@ free variables.-  }-  deriving (Data, Show)--type LocalDisplayForm = Open DisplayForm---- | A structured presentation of a 'Term' for reification into---   'Abstract.Syntax'.-data DisplayTerm-  = DWithApp DisplayTerm [DisplayTerm] Elims-    -- ^ @(f vs | ws) es@.-    --   The first 'DisplayTerm' is the parent function @f@ with its args @vs@.-    --   The list of 'DisplayTerm's are the with expressions @ws@.-    --   The 'Elims' are additional arguments @es@-    --   (possible in case the with-application is of function type)-    --   or projections (if it is of record type).-  | DCon ConHead ConInfo [Arg DisplayTerm]-    -- ^ @c vs@.-  | DDef QName [Elim' DisplayTerm]-    -- ^ @d vs@.-  | DDot Term-    -- ^ @.v@.-  | DTerm Term-    -- ^ @v@.-  deriving (Data, Show)--instance Free DisplayForm where-  freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t)--instance Free DisplayTerm where-  freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))-  freeVars' (DCon _ _ vs)      = freeVars' vs-  freeVars' (DDef _ es)        = freeVars' es-  freeVars' (DDot v)           = freeVars' v-  freeVars' (DTerm v)          = freeVars' v--instance Pretty DisplayTerm where-  prettyPrec p v =-    case v of-      DTerm v          -> prettyPrec p v-      DDot v           -> "." <> prettyPrec 10 v-      DDef f es        -> pretty f `pApp` es-      DCon c _ vs      -> pretty (conName c) `pApp` map Apply vs-      DWithApp h ws es ->-        mparens (p > 0)-          (sep [ pretty h-              , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ])-        `pApp` es-    where-      pApp :: Pretty el => Doc -> [el] -> Doc-      pApp d els = mparens (not (null els) && p > 9) $-                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]---- | By default, we have no display form.-defaultDisplayForm :: QName -> [LocalDisplayForm]-defaultDisplayForm c = []---- | Non-linear (non-constructor) first-order pattern.-data NLPat-  = PVar !Int [Arg Int]-    -- ^ Matches anything (modulo non-linearity) that only contains bound-    --   variables that occur in the given arguments.-  | PDef QName PElims-    -- ^ Matches @f es@-  | PLam ArgInfo (Abs NLPat)-    -- ^ Matches @λ x → t@-  | PPi (Dom NLPType) (Abs NLPType)-    -- ^ Matches @(x : A) → B@-  | PSort NLPSort-    -- ^ Matches a sort of the given shape.-  | PBoundVar {-# UNPACK #-} !Int PElims-    -- ^ Matches @x es@ where x is a lambda-bound variable-  | PTerm Term-    -- ^ Matches the term modulo β (ideally βη).-  deriving (Data, Show)-type PElims = [Elim' NLPat]--data NLPType = NLPType-  { nlpTypeSort :: NLPSort-  , nlpTypeUnEl :: NLPat-  } deriving (Data, Show)--data NLPSort-  = PType NLPat-  | PProp NLPat-  | PInf-  | PSizeUniv-  deriving (Data, Show)--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@.-  }-    deriving (Data, Show)--data Definition = Defn-  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.-  , defName           :: QName   -- ^ The canonical name, used e.g. in compilation.-  , defType           :: Type    -- ^ Type of the lifted definition.-  , defPolarity       :: [Polarity]-    -- ^ Variance information on arguments of the definition.-    --   Does not include info for dropped parameters to-    --   projection(-like) functions and constructors.-  , defArgOccurrences :: [Occurrence]-    -- ^ Positivity information on arguments of the definition.-    --   Does not include info for dropped parameters to-    --   projection(-like) functions and constructors.--    --   Sometimes Agda looks up 'Occurrence's in these lists based on-    --   their position, so one might consider replacing the list-    --   with, say, an 'IntMap'. However, presumably these lists tend-    --   to be short, in which case 'IntMap's could be slower than-    --   lists. For instance, at one point the longest list-    --   encountered for the standard library (in serialised-    --   interfaces) had length 27. Distribution:-    ---    --   Length, number of lists-    --   ------------------------    ---    --    0, 2444-    --    1,  721-    --    2,  433-    --    3,  668-    --    4,  602-    --    5,  624-    --    6,  626-    --    7,  484-    --    8,  375-    --    9,  264-    --   10,  305-    --   11,  188-    --   12,  171-    --   13,  108-    --   14,   84-    --   15,   80-    --   16,   38-    --   17,   23-    --   18,   16-    --   19,    8-    --   20,    7-    --   21,    5-    --   22,    2-    --   23,    3-    --   27,    1--  , defArgGeneralizable :: NumGeneralizableArgs-    -- ^ How many arguments should be generalised.-  , defGeneralizedParams :: [Maybe Name]-    -- ^ Gives the name of the (bound variable) parameter for named generalized-    --   parameters. This is needed to bring it into scope when type checking-    --   the data/record definition corresponding to a type with generalized-    --   parameters.-  , defDisplay        :: [LocalDisplayForm]-  , defMutual         :: MutualId-  , defCompiledRep    :: CompiledRepresentation-  , defInstance       :: Maybe QName-    -- ^ @Just q@ when this definition is an instance of class q-  , defCopy           :: Bool-    -- ^ Has this function been created by a module-                         -- instantiation?-  , defMatchable      :: Set QName-    -- ^ The set of symbols with rewrite rules that match against this symbol-  , defNoCompilation  :: Bool-    -- ^ should compilers skip this? Used for e.g. cubical's comp-  , defInjective      :: Bool-    -- ^ Should the def be treated as injective by the pattern matching unifier?-  , defCopatternLHS   :: Bool-    -- ^ Is this a function defined by copatterns?-  , defBlocked        :: Blocked_-    -- ^ What blocking tag to use when we cannot reduce this def?-    --   Used when checking a function definition is blocked on a meta-    --   in the type.-  , theDef            :: Defn-  }-    deriving (Data, Show)--instance LensArgInfo Definition where-  getArgInfo = defArgInfo-  mapArgInfo f def = def { defArgInfo = f $ defArgInfo def }--instance LensModality  Definition where-instance LensQuantity  Definition where-instance LensRelevance Definition where--data NumGeneralizableArgs-  = NoGeneralizableArgs-  | SomeGeneralizableArgs Int-    -- ^ When lambda-lifting new args are generalizable if-    --   'SomeGeneralizableArgs', also when the number is zero.-  deriving (Data, Show)--theDefLens :: Lens' Defn Definition-theDefLens f d = f (theDef d) <&> \ df -> d { theDef = df }---- | Create a definition with sensible defaults.-defaultDefn :: ArgInfo -> QName -> Type -> Defn -> Definition-defaultDefn info x t def = Defn-  { defArgInfo        = info-  , defName           = x-  , defType           = t-  , defPolarity       = []-  , defArgOccurrences = []-  , defArgGeneralizable = NoGeneralizableArgs-  , defGeneralizedParams = []-  , defDisplay        = defaultDisplayForm x-  , defMutual         = 0-  , defCompiledRep    = noCompiledRep-  , defInstance       = Nothing-  , defCopy           = False-  , defMatchable      = Set.empty-  , defNoCompilation  = False-  , defInjective      = False-  , defCopatternLHS   = False-  , defBlocked        = NotBlocked ReallyNotBlocked ()-  , theDef            = def-  }---- | Polarity for equality and subtype checking.-data Polarity-  = Covariant      -- ^ monotone-  | Contravariant  -- ^ antitone-  | Invariant      -- ^ no information (mixed variance)-  | Nonvariant     -- ^ constant-  deriving (Data, Show, Eq)--instance Pretty Polarity where-  pretty = text . \case-    Covariant     -> "+"-    Contravariant -> "-"-    Invariant     -> "*"-    Nonvariant    -> "_"---- | Information about whether an argument is forced by the type of a function.-data IsForced-  = Forced-  | NotForced-  deriving (Data, Show, Eq)---- | The backends are responsible for parsing their own pragmas.-data CompilerPragma = CompilerPragma Range String-  deriving (Data, Show, Eq)--instance HasRange CompilerPragma where-  getRange (CompilerPragma r _) = r--type BackendName    = String--jsBackendName, ghcBackendName :: BackendName-jsBackendName  = "JS"-ghcBackendName = "GHC"--type CompiledRepresentation = Map BackendName [CompilerPragma]--noCompiledRep :: CompiledRepresentation-noCompiledRep = Map.empty---- A face represented as a list of equality constraints.--- (r,False) ↦ (r = i0)--- (r,True ) ↦ (r = i1)-type Face = [(Term,Bool)]---- | An alternative representation of partial elements in a telescope:---   Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T---   see cubicaltt paper (however we do not store the type T).-data System = System-  { systemTel :: Telescope-    -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ-  , systemClauses :: [(Face,Term)]-    -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ-  } deriving (Data, Show)---- | 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.-  , extLamSys :: !(Strict.Maybe System)-  } deriving (Data, Show)--modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo-modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e'---- | Additional information for projection 'Function's.-data Projection = Projection-  { projProper    :: Maybe QName-    -- ^ @Nothing@ if only projection-like, @Just r@ if record projection.-    --   The @r@ is the name of the record type projected from.-    --   This field is updated by module application.-  , projOrig      :: QName-    -- ^ The original projection name-    --   (current name could be from module application).-  , projFromType  :: Arg QName-    -- ^ Type projected from. Original record type if @projProper = Just{}@.-    --   Also stores @ArgInfo@ of the principal argument.-    --   This field is unchanged by module application.-  , projIndex     :: Int-    -- ^ Index of the record argument.-    --   Start counting with 1, because 0 means that-    --   it is already applied to the record value.-    --   This can happen in module instantiation, but-    --   then either the record value is @var 0@, or @funProjection == Nothing@.-  , projLams :: ProjLams-    -- ^ Term @t@ to be be applied to record parameters and record value.-    --   The parameters will be dropped.-    --   In case of a proper projection, a postfix projection application-    --   will be created: @t = \ pars r -> r .p@-    --   (Invariant: the number of abstractions equals 'projIndex'.)-    --   In case of a projection-like function, just the function symbol-    --   is returned as 'Def':  @t = \ pars -> f@.-  } deriving (Data, Show)---- | Abstractions to build projection function (dropping parameters).-newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }-  deriving (Data, Show, Null)---- | 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 _ _ _ lams) o | null lams = __IMPOSSIBLE__-projDropPars (Projection Nothing d _ _ lams) o =-  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $ init $ getProjLams lams---- | The info of the principal (record) argument.-projArgInfo :: Projection -> ArgInfo-projArgInfo (Projection _ _ _ _ lams) =-  maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams---- | Should a record type admit eta-equality?-data EtaEquality-  = Specified { theEtaEquality :: !HasEta }  -- ^ User specifed 'eta-equality' or 'no-eta-equality'.-  | Inferred  { theEtaEquality :: !HasEta }  -- ^ Positivity checker inferred whether eta is safe.-  deriving (Data, Show, Eq)---- | Make sure we do not overwrite a user specification.-setEtaEquality :: EtaEquality -> HasEta -> EtaEquality-setEtaEquality e@Specified{} _ = e-setEtaEquality _ b = Inferred b--data FunctionFlag-  = FunStatic  -- ^ Should calls to this function be normalised at compile-time?-  | FunInline  -- ^ Should calls to this function be inlined by the compiler?-  | FunMacro   -- ^ Is this function a macro?-  deriving (Data, Eq, Ord, Enum, Show)--data CompKit = CompKit-  { nameOfHComp :: Maybe QName-  , nameOfTransp :: Maybe QName-  }-  deriving (Data, Eq, Ord, Show)--emptyCompKit :: CompKit-emptyCompKit = CompKit Nothing Nothing--data Defn = Axiom -- ^ Postulate-          | DataOrRecSig-            { datarecPars :: Int }-            -- ^ Data or record type signature that doesn't yet have a definition-          | GeneralizableVar -- ^ Generalizable variable (introduced in `generalize` block)-          | AbstractDefn Defn-            -- ^ Returned by 'getConstInfo' if definition is abstract.-          | Function-            { funClauses        :: [Clause]-            , funCompiled       :: Maybe CompiledClauses-              -- ^ 'Nothing' while function is still type-checked.-              --   @Just cc@ after type and coverage checking and-              --   translation to case trees.-            , funSplitTree      :: Maybe SplitTree-              -- ^ The split tree constructed by the coverage-              --   checker. Needed to re-compile the clauses after-              --   forcing translation.-            , funTreeless       :: Maybe Compiled-              -- ^ Intermediate representation for compiler backends.-            , funCovering       :: [Clause]-              -- ^ Covering clauses computed by coverage checking.-              --   Erased by (IApply) confluence checking(?)-            , funInv            :: FunctionInverse-            , funMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this function.-              --   Empty list if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , funAbstr          :: IsAbstract-            , funDelayed        :: Delayed-              -- ^ Are the clauses of this definition delayed?-            , funProjection     :: Maybe Projection-              -- ^ Is it a record projection?-              --   If yes, then return the name of the record type and index of-              --   the record argument.  Start counting with 1, because 0 means that-              --   it is already applied to the record. (Can happen in module-              --   instantiation.) This information is used in the termination-              --   checker.-            , funFlags          :: Set FunctionFlag-            , funTerminates     :: Maybe Bool-              -- ^ Has this function been termination checked?  Did it pass?-            , funExtLam         :: Maybe ExtLamInfo-              -- ^ Is this function generated from an extended lambda?-              --   If yes, then return the number of hidden and non-hidden lambda-lifted arguments-            , funWith           :: Maybe QName-              -- ^ Is this a generated with-function? If yes, then what's the-              --   name of the parent function.-            }-          | Datatype-            { dataPars           :: Nat            -- ^ Number of parameters.-            , dataIxs            :: Nat            -- ^ Number of indices.-            , dataClause         :: (Maybe Clause) -- ^ This might be in an instantiated module.-            , dataCons           :: [QName]-              -- ^ Constructor names , ordered according to the order of their definition.-            , dataSort           :: Sort-            , dataMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this data type.-              --   Empty if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , dataAbstr          :: IsAbstract-            , dataPathCons       :: [QName]        -- ^ Path constructor names (subset of dataCons)-            }-          | Record-            { recPars           :: Nat-              -- ^ Number of parameters.-            , recClause         :: Maybe Clause-              -- ^ Was this record type created by a module application?-              --   If yes, the clause is its definition (linking back to the original record type).-            , recConHead        :: ConHead-              -- ^ Constructor name and fields.-            , recNamedCon       :: Bool-              -- ^ Does this record have a @constructor@?-            , recFields         :: [Dom QName]-              -- ^ The record field names.-            , recTel            :: Telescope-              -- ^ The record field telescope. (Includes record parameters.)-              --   Note: @TelV recTel _ == telView' recConType@.-              --   Thus, @recTel@ is redundant.-            , recMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this record.-              --   Empty if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , recEtaEquality'    :: EtaEquality-              -- ^ Eta-expand at this record type?-              --   @False@ for unguarded recursive records and coinductive records-              --   unless the user specifies otherwise.-            , recInduction      :: Maybe Induction-              -- ^ 'Inductive' or 'CoInductive'?  Matters only for recursive records.-              --   'Nothing' means that the user did not specify it, which is an error-              --   for recursive records.-            , recAbstr          :: IsAbstract-            , recComp           :: CompKit-            }-          | Constructor-            { conPars   :: Int         -- ^ Number of parameters.-            , conArity  :: Int         -- ^ Number of arguments (excluding parameters).-            , conSrcCon :: ConHead     -- ^ Name of (original) constructor and fields. (This might be in a module instance.)-            , conData   :: QName       -- ^ Name of datatype or record type.-            , conAbstr  :: IsAbstract-            , conInd    :: Induction   -- ^ Inductive or coinductive?-            , conComp   :: CompKit     -- ^ Cubical composition.-            , conProj   :: Maybe [QName] -- ^ Projections. 'Nothing' if not yet computed.-            , conForced :: [IsForced]-              -- ^ Which arguments are forced (i.e. determined by the type of the constructor)?-              --   Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@.-            , conErased :: Maybe [Bool]-              -- ^ Which arguments are erased at runtime (computed during compilation to treeless)?-              --   'True' means erased, 'False' means retained.-              --   'Nothing' if no erasure analysis has been performed yet.-              --   The length of the list is @conArity@.-            }-          | Primitive-            { primAbstr :: IsAbstract-            , primName  :: String-            , primClauses :: [Clause]-              -- ^ 'null' for primitive functions, @not null@ for builtin functions.-            , primInv      :: FunctionInverse-              -- ^ Builtin functions can have inverses. For instance, natural number addition.-            , primCompiled :: Maybe CompiledClauses-              -- ^ 'Nothing' for primitive functions,-              --   @'Just' something@ for builtin functions.-            }-            -- ^ Primitive or builtin functions.-    deriving (Data, Show)--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        =" <?> pshow defDisplay -- TODO: pretty DisplayForm-      , "defMutual         =" <?> pshow defMutual-      , "defCompiledRep    =" <?> pshow defCompiledRep-      , "defInstance       =" <?> pshow defInstance-      , "defCopy           =" <?> pshow defCopy-      , "defMatchable      =" <?> pshow (Set.toList defMatchable)-      , "defInjective      =" <?> pshow defInjective-      , "defCopatternLHS   =" <?> pshow defCopatternLHS-      , "theDef            =" <?> pretty theDef ] <+> "}"--instance Pretty Defn where-  pretty Axiom = "Axiom"-  pretty (DataOrRecSig n)   = "DataOrRecSig" <+> pretty n-  pretty GeneralizableVar{} = "GeneralizableVar"-  pretty (AbstractDefn def) = "AbstractDefn" <?> parens (pretty def)-  pretty Function{..} =-    "Function {" <?> vcat-      [ "funClauses      =" <?> vcat (map pretty funClauses)-      , "funCompiled     =" <?> pshow funCompiled-      , "funSplitTree    =" <?> pshow funSplitTree-      , "funTreeless     =" <?> pshow funTreeless-      , "funInv          =" <?> pshow funInv-      , "funMutual       =" <?> pshow funMutual-      , "funAbstr        =" <?> pshow funAbstr-      , "funDelayed      =" <?> pshow funDelayed-      , "funProjection   =" <?> pshow funProjection-      , "funFlags        =" <?> pshow funFlags-      , "funTerminates   =" <?> pshow funTerminates-      , "funWith         =" <?> pshow funWith ] <?> "}"-  pretty Datatype{..} =-    "Datatype {" <?> vcat-      [ "dataPars       =" <?> pshow dataPars-      , "dataIxs        =" <?> pshow dataIxs-      , "dataClause     =" <?> pretty dataClause-      , "dataCons       =" <?> pshow dataCons-      , "dataSort       =" <?> pretty dataSort-      , "dataMutual     =" <?> pshow dataMutual-      , "dataAbstr      =" <?> pshow dataAbstr ] <?> "}"-  pretty Record{..} =-    "Record {" <?> vcat-      [ "recPars         =" <?> pshow recPars-      , "recClause       =" <?> pretty recClause-      , "recConHead      =" <?> pshow recConHead-      , "recNamedCon     =" <?> pshow recNamedCon-      , "recFields       =" <?> pshow recFields-      , "recTel          =" <?> pretty recTel-      , "recMutual       =" <?> pshow recMutual-      , "recEtaEquality' =" <?> pshow recEtaEquality'-      , "recInduction    =" <?> pshow recInduction-      , "recAbstr        =" <?> pshow recAbstr ] <?> "}"-  pretty Constructor{..} =-    "Constructor {" <?> vcat-      [ "conPars   =" <?> pshow conPars-      , "conArity  =" <?> pshow conArity-      , "conSrcCon =" <?> pshow conSrcCon-      , "conData   =" <?> pshow conData-      , "conAbstr  =" <?> pshow conAbstr-      , "conInd    =" <?> pshow conInd-      , "conErased =" <?> pshow conErased ] <?> "}"-  pretty Primitive{..} =-    "Primitive {" <?> vcat-      [ "primAbstr    =" <?> pshow primAbstr-      , "primName     =" <?> pshow primName-      , "primClauses  =" <?> pshow primClauses-      , "primCompiled =" <?> pshow primCompiled ] <?> "}"----- | Is the record type recursive?-recRecursive :: Defn -> Bool-recRecursive (Record { recMutual = Just qs }) = not $ null qs-recRecursive _ = __IMPOSSIBLE__--recEtaEquality :: Defn -> HasEta-recEtaEquality = theEtaEquality . recEtaEquality'---- | A template for creating 'Function' definitions, with sensible defaults.-emptyFunction :: Defn-emptyFunction = Function-  { funClauses     = []-  , funCompiled    = Nothing-  , funSplitTree   = Nothing-  , funTreeless    = Nothing-  , funInv         = NotInjective-  , funMutual      = Nothing-  , funAbstr       = ConcreteDef-  , funDelayed     = NotDelayed-  , funProjection  = Nothing-  , funFlags       = Set.empty-  , funTerminates  = Nothing-  , funExtLam      = Nothing-  , funWith        = Nothing-  , funCovering    = []-  }--funFlag :: FunctionFlag -> Lens' Bool Defn-funFlag flag f def@Function{ funFlags = flags } =-  f (Set.member flag flags) <&>-  \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags }-funFlag _ f def = f False <&> const def--funStatic, funInline, funMacro :: Lens' Bool Defn-funStatic       = funFlag FunStatic-funInline       = funFlag FunInline-funMacro        = funFlag FunMacro--isMacro :: Defn -> Bool-isMacro = (^. funMacro)---- | Checking whether we are dealing with a function yet to be defined.-isEmptyFunction :: Defn -> Bool-isEmptyFunction def =-  case def of-    Function { funClauses = [] } -> True-    _ -> False--isCopatternLHS :: [Clause] -> Bool-isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)--recCon :: Defn -> QName-recCon Record{ recConHead } = conName recConHead-recCon _ = __IMPOSSIBLE__--defIsRecord :: Defn -> Bool-defIsRecord Record{} = True-defIsRecord _        = False--defIsDataOrRecord :: Defn -> Bool-defIsDataOrRecord Record{}   = True-defIsDataOrRecord Datatype{} = True-defIsDataOrRecord _          = False--defConstructors :: Defn -> [QName]-defConstructors Datatype{dataCons = cs} = cs-defConstructors Record{recConHead = c} = [conName c]-defConstructors _ = __IMPOSSIBLE__--newtype Fields = Fields [(C.Name, Type)]-  deriving Null---- | Did we encounter a simplifying reduction?---   In terms of CIC, that would be a iota-reduction.---   In terms of Agda, this is a constructor or literal---   pattern that matched.---   Just beta-reduction (substitution) or delta-reduction---   (unfolding of definitions) does not count as simplifying?--data Simplification = YesSimplification | NoSimplification-  deriving (Data, Eq, Show)--instance Null Simplification where-  empty = NoSimplification-  null  = (== NoSimplification)--instance Semigroup Simplification where-  YesSimplification <> _ = YesSimplification-  NoSimplification  <> s = s--instance Monoid Simplification where-  mempty = NoSimplification-  mappend = (<>)--data Reduced no yes-  = NoReduction no-  | YesReduction Simplification yes-  deriving Functor--redReturn :: a -> ReduceM (Reduced a' a)-redReturn = return . YesReduction YesSimplification---- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@--redBind :: ReduceM (Reduced a a') -> (a -> b) ->-           (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')-redBind ma f k = do-  r <- ma-  case r of-    NoReduction x    -> return $ NoReduction $ f x-    YesReduction _ y -> k y---- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked.-data IsReduced-  = NotReduced-  | Reduced    (Blocked ())--data MaybeReduced a = MaybeRed-  { isReduced     :: IsReduced-  , ignoreReduced :: a-  }-  deriving (Functor)--instance IsProjElim e => IsProjElim (MaybeReduced e) where-  isProjElim = isProjElim . ignoreReduced--type MaybeReducedArgs = [MaybeReduced (Arg Term)]-type MaybeReducedElims = [MaybeReduced Elim]--notReduced :: a -> MaybeReduced a-notReduced x = MaybeRed NotReduced x--reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)-reduced b = case b of-  NotBlocked _ (Arg _ (MetaV x _)) -> MaybeRed (Reduced $ Blocked x ()) v-  _                                -> MaybeRed (Reduced $ () <$ b)      v-  where-    v = ignoreBlocking b---- | Controlling 'reduce'.-data AllowedReduction-  = ProjectionReductions     -- ^ (Projection and) projection-like functions may be reduced.-  | InlineReductions         -- ^ Functions marked INLINE may be reduced.-  | CopatternReductions      -- ^ Copattern definitions may be reduced.-  | FunctionReductions       -- ^ Non-recursive functions and primitives may be reduced.-  | RecursiveReductions      -- ^ Even recursive functions may be reduced.-  | LevelReductions          -- ^ Reduce @'Level'@ terms.-  | TypeLevelReductions      -- ^ Allow @allReductions@ in types, even-                             --   if not allowed at term level (used-                             --   by confluence checker)-  | UnconfirmedReductions    -- ^ Functions whose termination has not (yet) been confirmed.-  | NonTerminatingReductions -- ^ Functions that have failed termination checking.-  deriving (Show, Eq, Ord, Enum, Bounded, Ix, Data)--type AllowedReductions = SmallSet AllowedReduction---- | Not quite all reductions (skip non-terminating reductions)-allReductions :: AllowedReductions-allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions--reallyAllReductions :: AllowedReductions-reallyAllReductions = SmallSet.total----- | Primitives--data PrimitiveImpl = PrimImpl Type PrimFun--data PrimFun = PrimFun-  { primFunName           :: QName-  , primFunArity          :: Arity-  , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)-  }--primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun-primFun q ar imp = PrimFun q ar (\ args _ -> imp args)--defClauses :: Definition -> [Clause]-defClauses Defn{theDef = Function{funClauses = cs}}        = cs-defClauses Defn{theDef = Primitive{primClauses = cs}}      = cs-defClauses Defn{theDef = Datatype{dataClause = Just c}}    = [c]-defClauses Defn{theDef = Record{recClause = Just c}}       = [c]-defClauses _                                               = []--defCompiled :: Definition -> Maybe CompiledClauses-defCompiled Defn{theDef = Function {funCompiled  = mcc}} = mcc-defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc-defCompiled _ = Nothing--defParameters :: Definition -> Maybe Nat-defParameters Defn{theDef = Datatype{dataPars = n}} = Just n-defParameters Defn{theDef = Record  {recPars  = n}} = Just n-defParameters _                                     = Nothing--defInverse :: Definition -> FunctionInverse-defInverse Defn{theDef = Function { funInv  = inv }} = inv-defInverse Defn{theDef = Primitive{ primInv = inv }} = inv-defInverse _                                         = NotInjective--defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma]-defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep-  -- reversed because we add new pragmas to the front of the list---- | Are the clauses of this definition delayed?-defDelayed :: Definition -> Delayed-defDelayed Defn{theDef = Function{funDelayed = d}} = d-defDelayed _                                       = NotDelayed---- | Has the definition failed the termination checker?-defNonterminating :: Definition -> Bool-defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True-defNonterminating _                                                   = False---- | Has the definition not termination checked or did the check fail?-defTerminationUnconfirmed :: Definition -> Bool-defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False-defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _        }} = True-defTerminationUnconfirmed _ = False--defAbstract :: Definition -> IsAbstract-defAbstract d = case theDef d of-    Axiom{}                   -> ConcreteDef-    DataOrRecSig{}            -> ConcreteDef-    GeneralizableVar{}        -> ConcreteDef-    AbstractDefn{}            -> AbstractDef-    Function{funAbstr = a}    -> a-    Datatype{dataAbstr = a}   -> a-    Record{recAbstr = a}      -> a-    Constructor{conAbstr = a} -> a-    Primitive{primAbstr = a}  -> a--defForced :: Definition -> [IsForced]-defForced d = case theDef d of-    Constructor{conForced = fs} -> fs-    Axiom{}                     -> []-    DataOrRecSig{}              -> []-    GeneralizableVar{}          -> []-    AbstractDefn{}              -> []-    Function{}                  -> []-    Datatype{}                  -> []-    Record{}                    -> []-    Primitive{}                 -> []-------------------------------------------------------------------------------- ** Injectivity------------------------------------------------------------------------------type FunctionInverse = FunctionInverse' Clause-type InversionMap c = Map TermHead [c]--data FunctionInverse' c-  = NotInjective-  | Inverse (InversionMap c)-  deriving (Data, Show, Functor)--data TermHead = SortHead-              | PiHead-              | ConsHead QName-              | VarHead Nat-              | UnknownHead-  deriving (Data, Eq, Ord, Show)--instance Pretty TermHead where-  pretty = \ case-    SortHead    -> "SortHead"-    PiHead      -> "PiHead"-    ConsHead q  -> "ConsHead" <+> pretty q-    VarHead i   -> text ("VarHead " ++ show i)-    UnknownHead -> "UnknownHead"-------------------------------------------------------------------------------- ** Mutual blocks------------------------------------------------------------------------------newtype MutualId = MutId Int32-  deriving (Data, Eq, Ord, Show, Num, Enum)-------------------------------------------------------------------------------- ** Statistics------------------------------------------------------------------------------type Statistics = Map String Integer-------------------------------------------------------------------------------- ** Trace------------------------------------------------------------------------------data Call-  = CheckClause Type A.SpineClause-  | CheckLHS A.SpineLHS-  | CheckPattern A.Pattern Telescope Type-  | CheckLetBinding A.LetBinding-  | InferExpr A.Expr-  | CheckExprCall Comparison A.Expr Type-  | CheckDotPattern A.Expr Term-  | CheckProjection Range QName Type-  | IsTypeCall Comparison A.Expr Sort-  | IsType_ A.Expr-  | InferVar Name-  | InferDef QName-  | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type)-  | CheckMetaSolution Range MetaId Type Term-  | CheckTargetType Range Type Type-  | CheckDataDef Range QName [A.LamBinding] [A.Constructor]-  | CheckRecDef Range QName [A.LamBinding] [A.Constructor]-  | CheckConstructor QName Telescope Sort A.Constructor-  | CheckConstructorFitsIn QName Type Sort-  | CheckFunDefCall Range QName [A.Clause]-  | CheckPragma Range A.Pragma-  | CheckPrimitive Range QName A.Expr-  | CheckIsEmpty Range Type-  | CheckConfluence QName QName-  | CheckWithFunctionType Type-  | CheckSectionApplication Range ModuleName A.ModuleApplication-  | CheckNamedWhere ModuleName-  | ScopeCheckExpr C.Expr-  | ScopeCheckDeclaration NiceDeclaration-  | ScopeCheckLHS C.QName C.Pattern-  | NoHighlighting-  | ModuleContents  -- ^ Interaction command: show module contents.-  | SetRange Range  -- ^ used by 'setCurrentRange'-  deriving Data--instance Pretty Call where-    pretty CheckClause{}             = "CheckClause"-    pretty CheckLHS{}                = "CheckLHS"-    pretty CheckPattern{}            = "CheckPattern"-    pretty InferExpr{}               = "InferExpr"-    pretty CheckExprCall{}           = "CheckExprCall"-    pretty CheckLetBinding{}         = "CheckLetBinding"-    pretty CheckProjection{}         = "CheckProjection"-    pretty IsTypeCall{}              = "IsTypeCall"-    pretty IsType_{}                 = "IsType_"-    pretty InferVar{}                = "InferVar"-    pretty InferDef{}                = "InferDef"-    pretty CheckArguments{}          = "CheckArguments"-    pretty CheckMetaSolution{}       = "CheckMetaSolution"-    pretty CheckTargetType{}         = "CheckTargetType"-    pretty CheckDataDef{}            = "CheckDataDef"-    pretty CheckRecDef{}             = "CheckRecDef"-    pretty CheckConstructor{}        = "CheckConstructor"-    pretty CheckConstructorFitsIn{}  = "CheckConstructorFitsIn"-    pretty CheckFunDefCall{}         = "CheckFunDefCall"-    pretty CheckPragma{}             = "CheckPragma"-    pretty CheckPrimitive{}          = "CheckPrimitive"-    pretty CheckWithFunctionType{}   = "CheckWithFunctionType"-    pretty CheckNamedWhere{}         = "CheckNamedWhere"-    pretty ScopeCheckExpr{}          = "ScopeCheckExpr"-    pretty ScopeCheckDeclaration{}   = "ScopeCheckDeclaration"-    pretty ScopeCheckLHS{}           = "ScopeCheckLHS"-    pretty CheckDotPattern{}         = "CheckDotPattern"-    pretty SetRange{}                = "SetRange"-    pretty CheckSectionApplication{} = "CheckSectionApplication"-    pretty CheckIsEmpty{}            = "CheckIsEmpty"-    pretty CheckConfluence{}         = "CheckConfluence"-    pretty NoHighlighting{}          = "NoHighlighting"-    pretty ModuleContents{}          = "ModuleContents"--instance HasRange Call where-    getRange (CheckClause _ c)               = getRange c-    getRange (CheckLHS lhs)                  = getRange lhs-    getRange (CheckPattern p _ _)            = getRange p-    getRange (InferExpr e)                   = getRange e-    getRange (CheckExprCall _ e _)           = getRange e-    getRange (CheckLetBinding b)             = getRange b-    getRange (CheckProjection r _ _)         = r-    getRange (IsTypeCall cmp e s)            = getRange e-    getRange (IsType_ e)                     = getRange e-    getRange (InferVar x)                    = getRange x-    getRange (InferDef f)                    = getRange f-    getRange (CheckArguments r _ _ _)        = r-    getRange (CheckMetaSolution r _ _ _)     = r-    getRange (CheckTargetType r _ _)         = r-    getRange (CheckDataDef i _ _ _)          = getRange i-    getRange (CheckRecDef i _ _ _)           = getRange i-    getRange (CheckConstructor _ _ _ c)      = getRange c-    getRange (CheckConstructorFitsIn c _ _)  = getRange c-    getRange (CheckFunDefCall i _ _)         = getRange i-    getRange (CheckPragma r _)               = r-    getRange (CheckPrimitive i _ _)          = getRange i-    getRange CheckWithFunctionType{}         = noRange-    getRange (CheckNamedWhere m)             = getRange m-    getRange (ScopeCheckExpr e)              = getRange e-    getRange (ScopeCheckDeclaration d)       = getRange d-    getRange (ScopeCheckLHS _ p)             = getRange p-    getRange (CheckDotPattern e _)           = getRange e-    getRange (SetRange r)                    = r-    getRange (CheckSectionApplication r _ _) = r-    getRange (CheckIsEmpty r _)              = r-    getRange (CheckConfluence rule1 rule2)   = max (getRange rule1) (getRange rule2)-    getRange NoHighlighting                  = noRange-    getRange ModuleContents                  = noRange-------------------------------------------------------------------------------- ** Instance table-------------------------------------------------------------------------------- | The instance table is a @Map@ associating to every name of---   record/data type/postulate its list of instances-type InstanceTable = Map QName (Set QName)---- | When typechecking something of the following form:------     instance---       x : _---       x = y------   it's not yet known where to add @x@, so we add it to a list of---   unresolved instances and we'll deal with it later.-type TempInstanceTable = (InstanceTable , Set QName)-------------------------------------------------------------------------------- ** Builtin things------------------------------------------------------------------------------data BuiltinDescriptor-  = BuiltinData (TCM Type) [String]-  | BuiltinDataCons (TCM Type)-  | BuiltinPrim String (Term -> TCM ())-  | BuiltinPostulate Relevance (TCM Type)-  | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ())-    -- ^ Builtin of any kind.-    --   Type can be checked (@Just t@) or inferred (@Nothing@).-    --   The second argument is the hook for the verification function.--data BuiltinInfo =-   BuiltinInfo { builtinName :: String-               , builtinDesc :: BuiltinDescriptor }--type BuiltinThings pf = Map String (Builtin pf)--data Builtin pf-        = Builtin Term-        | Prim pf-    deriving (Show, Functor, Foldable, Traversable)-------------------------------------------------------------------------------- * Highlighting levels-------------------------------------------------------------------------------- | How much highlighting should be sent to the user interface?--data HighlightingLevel-  = None-  | NonInteractive-  | Interactive-    -- ^ This includes both non-interactive highlighting and-    -- interactive highlighting of the expression that is currently-    -- being type-checked.-    deriving (Eq, Ord, Show, Read, Data)---- | How should highlighting be sent to the user interface?--data HighlightingMethod-  = Direct-    -- ^ Via stdout.-  | Indirect-    -- ^ Both via files and via stdout.-    deriving (Eq, Show, Read, Data)---- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're--- type-checking the top-level module and either the highlighting--- level is /at least/ @l@ or @b@ is 'True'.--ifTopLevelAndHighlightingLevelIsOr ::-  MonadTCM tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIsOr l b m = do-  e <- askTC-  when (envModuleNestingLevel e == 0 &&-        (envHighlightingLevel e >= l || b))-       m---- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're--- type-checking the top-level module and the highlighting level is--- /at least/ @l@.--ifTopLevelAndHighlightingLevelIs ::-  MonadTCM tcm => HighlightingLevel -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIs l =-  ifTopLevelAndHighlightingLevelIsOr l False-------------------------------------------------------------------------------- * Type checking environment------------------------------------------------------------------------------data TCEnv =-    TCEnv { envContext             :: Context-          , envLetBindings         :: LetBindings-          , envCurrentModule       :: ModuleName-          , envCurrentPath         :: Maybe AbsolutePath-            -- ^ The path to the file that is currently being-            -- type-checked.  'Nothing' if we do not have a file-            -- (like in interactive mode see @CommandLine@).-          , envAnonymousModules    :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables-          , envImportPath          :: [C.TopLevelModuleName] -- ^ to detect import cycles-          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block-          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma-          , envCoverageCheck       :: CoverageCheck        -- ^ are we inside the scope of a coverage pragma-          , envMakeCase            :: Bool                 -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier)-          , envSolvingConstraints  :: Bool-                -- ^ Are we currently in the process of solving active constraints?-          , envCheckingWhere       :: Bool-                -- ^ Have we stepped into the where-declarations of a clause?-                --   Everything under a @where@ will be checked with this flag on.-          , envWorkingOnTypes      :: Bool-                -- ^ Are we working on types? Turned on by 'workOnTypes'.-          , envAssignMetas         :: Bool-            -- ^ Are we allowed to assign metas?-          , envActiveProblems      :: Set ProblemId-          , envAbstractMode        :: AbstractMode-                -- ^ When checking the typesignature of a public definition-                --   or the body of a non-abstract definition this is true.-                --   To prevent information about abstract things leaking-                --   outside the module.-          , envModality            :: Modality-                -- ^ 'Relevance' component:-                -- Are we checking an irrelevant argument? (=@Irrelevant@)-                -- Then top-level irrelevant declarations are enabled.-                -- Other value: @Relevant@, then only relevant decls. are available.-                ---                -- 'Quantity' component:-                -- Are we checking a runtime-irrelevant thing? (='Quantity0')-                -- Then runtime-irrelevant things are usable.-                -- Other value: @Quantity1@, runtime relevant.-                -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018.-          , envDisplayFormsEnabled :: Bool-                -- ^ Sometimes we want to disable display forms.-          , envRange :: Range-          , envHighlightingRange :: Range-                -- ^ Interactive highlighting uses this range rather-                --   than 'envRange'.-          , envClause :: IPClause-                -- ^ What is the current clause we are type-checking?-                --   Will be recorded in interaction points in this clause.-          , envCall  :: Maybe (Closure Call)-                -- ^ what we're doing at the moment-          , envHighlightingLevel  :: HighlightingLevel-                -- ^ Set to 'None' when imported modules are-                --   type-checked.-          , envHighlightingMethod :: HighlightingMethod-          , envModuleNestingLevel :: !Int-                -- ^ This number indicates how far away from the-                --   top-level module Agda has come when chasing-                --   modules. 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.-          , envExpandLast :: ExpandHidden-                -- ^ When type-checking an alias f=e, we do not want-                -- to insert hidden arguments in the end, because-                -- these will become unsolved metas.-          , envAppDef :: Maybe QName-                -- ^ We are reducing an application of this function.-                -- (For debugging of incomplete matches only.)-          , envSimplification :: Simplification-                -- ^ Did we encounter a simplification (proper match)-                --   during the current reduction process?-          , envAllowedReductions :: AllowedReductions-          , 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.-          , envCheckOptionConsistency :: Bool-                -- ^ Do we check that options in imported files are-                --   consistent with each other?-          , 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'.-          }-    deriving Data--initEnv :: TCEnv-initEnv = TCEnv { envContext             = []-                , envLetBindings         = Map.empty-                , envCurrentModule       = noModuleName-                , envCurrentPath         = Nothing-                , envAnonymousModules    = []-                , envImportPath          = []-                , envMutualBlock         = Nothing-                , envTerminationCheck    = TerminationCheck-                , envCoverageCheck       = YesCoverageCheck-                , envMakeCase            = False-                , envSolvingConstraints  = False-                , envCheckingWhere       = False-                , envActiveProblems      = Set.empty-                , envWorkingOnTypes      = False-                , envAssignMetas         = True-                , envAbstractMode        = ConcreteMode-  -- Andreas, 2013-02-21:  This was 'AbstractMode' until now.-  -- However, top-level checks for mutual blocks, such as-  -- constructor-headedness, should not be able to look into-  -- abstract definitions unless abstract themselves.-  -- (See also discussion on issue 796.)-  -- The initial mode should be 'ConcreteMode', ensuring you-  -- can only look into abstract things in an abstract-  -- definition (which sets 'AbstractMode').-                , envModality               = mempty-                , envDisplayFormsEnabled    = True-                , envRange                  = noRange-                , envHighlightingRange      = noRange-                , envClause                 = IPNoClause-                , envCall                   = Nothing-                , envHighlightingLevel      = None-                , envHighlightingMethod     = Indirect-                , envModuleNestingLevel     = -1-                , envExpandLast             = ExpandLast-                , envAppDef                 = Nothing-                , envSimplification         = NoSimplification-                , envAllowedReductions      = allReductions-                , 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-                , envCheckOptionConsistency = True-                , envActiveBackendName      = Nothing-                }--class LensTCEnv a where-  lensTCEnv :: Lens' TCEnv a--instance LensTCEnv TCEnv where-  lensTCEnv = id--instance LensModality TCEnv where-  -- Cohesion shouldn't have an environment component.-  getModality = setCohesion defaultCohesion . envModality-  mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e }--instance LensRelevance TCEnv where-instance LensQuantity  TCEnv where--data UnquoteFlags = UnquoteFlags-  { _unquoteNormalise :: Bool }-  deriving Data--defaultUnquoteFlags :: UnquoteFlags-defaultUnquoteFlags = UnquoteFlags-  { _unquoteNormalise = False }--unquoteNormalise :: Lens' Bool UnquoteFlags-unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }--eUnquoteNormalise :: Lens' Bool TCEnv-eUnquoteNormalise = eUnquoteFlags . unquoteNormalise---- * e-prefixed lenses---------------------------------------------------------------------------eContext :: Lens' Context TCEnv-eContext f e = f (envContext e) <&> \ x -> e { envContext = x }--eLetBindings :: Lens' LetBindings TCEnv-eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }--eCurrentModule :: Lens' ModuleName TCEnv-eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }--eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv-eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }--eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv-eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }--eImportPath :: Lens' [C.TopLevelModuleName] TCEnv-eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }--eMutualBlock :: Lens' (Maybe MutualId) TCEnv-eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }--eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv-eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }--eCoverageCheck :: Lens' CoverageCheck TCEnv-eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }--eMakeCase :: Lens' Bool TCEnv-eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }--eSolvingConstraints :: Lens' Bool TCEnv-eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }--eCheckingWhere :: Lens' Bool TCEnv-eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }--eWorkingOnTypes :: Lens' Bool TCEnv-eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }--eAssignMetas :: Lens' Bool TCEnv-eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }--eActiveProblems :: Lens' (Set ProblemId) TCEnv-eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }--eAbstractMode :: Lens' AbstractMode TCEnv-eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }---- Andrea 23/02/2020: use get/setModality to enforce invariants of the---                    envModality field.-eModality :: Lens' Modality TCEnv-eModality f e = f (getModality e) <&> \ x -> setModality x e--eRelevance :: Lens' Relevance TCEnv-eRelevance = eModality . lModRelevance--eQuantity :: Lens' Quantity TCEnv-eQuantity = eModality . lModQuantity--eDisplayFormsEnabled :: Lens' Bool TCEnv-eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }--eRange :: Lens' Range TCEnv-eRange f e = f (envRange e) <&> \ x -> e { envRange = x }--eHighlightingRange :: Lens' Range TCEnv-eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }--eCall :: Lens' (Maybe (Closure Call)) TCEnv-eCall f e = f (envCall e) <&> \ x -> e { envCall = x }--eHighlightingLevel :: Lens' HighlightingLevel TCEnv-eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }--eHighlightingMethod :: Lens' HighlightingMethod TCEnv-eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }--eModuleNestingLevel :: Lens' Int TCEnv-eModuleNestingLevel f e = f (envModuleNestingLevel e) <&> \ x -> e { envModuleNestingLevel = x }--eExpandLast :: Lens' ExpandHidden TCEnv-eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }--eAppDef :: Lens' (Maybe QName) TCEnv-eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }--eSimplification :: Lens' Simplification TCEnv-eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }--eAllowedReductions :: Lens' AllowedReductions TCEnv-eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }--eInjectivityDepth :: Lens' Int TCEnv-eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }--eCompareBlocked :: Lens' Bool TCEnv-eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }--ePrintDomainFreePi :: Lens' Bool TCEnv-ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }--eInsideDotPattern :: Lens' Bool TCEnv-eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }--eUnquoteFlags :: Lens' UnquoteFlags TCEnv-eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }--eInstanceDepth :: Lens' Int TCEnv-eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }--eIsDebugPrinting :: Lens' Bool TCEnv-eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }--ePrintingPatternLambdas :: Lens' [QName] TCEnv-ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }--eCallByNeed :: Lens' Bool TCEnv-eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }--eCurrentCheckpoint :: Lens' CheckpointId TCEnv-eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }--eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv-eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }--eGeneralizeMetas :: Lens' DoGeneralize TCEnv-eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }--eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv-eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }--eActiveBackendName :: Lens' (Maybe BackendName) TCEnv-eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }-------------------------------------------------------------------------------- ** Context-------------------------------------------------------------------------------- | The @Context@ is a stack of 'ContextEntry's.-type Context      = [ContextEntry]-type ContextEntry = Dom (Name, Type)-------------------------------------------------------------------------------- ** Let bindings------------------------------------------------------------------------------type LetBindings = Map Name (Open (Term, Dom Type))-------------------------------------------------------------------------------- ** Abstract mode------------------------------------------------------------------------------data AbstractMode-  = AbstractMode        -- ^ Abstract things in the current module can be accessed.-  | ConcreteMode        -- ^ No abstract things can be accessed.-  | IgnoreAbstractMode  -- ^ All abstract things can be accessed.-  deriving (Data, Show, Eq)--aDefToMode :: IsAbstract -> AbstractMode-aDefToMode AbstractDef = AbstractMode-aDefToMode ConcreteDef = ConcreteMode--aModeToDef :: AbstractMode -> Maybe IsAbstract-aModeToDef AbstractMode = Just AbstractDef-aModeToDef ConcreteMode = Just ConcreteDef-aModeToDef _ = Nothing-------------------------------------------------------------------------------- ** Insertion of implicit arguments------------------------------------------------------------------------------data ExpandHidden-  = ExpandLast      -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.-  | DontExpandLast  -- ^ Do not append implicit arguments.-  | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables.-  deriving (Eq, Data)--isDontExpandLast :: ExpandHidden -> Bool-isDontExpandLast ExpandLast           = False-isDontExpandLast DontExpandLast       = True-isDontExpandLast ReallyDontExpandLast = True---- | 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 { candidateTerm :: Term-                            , candidateType :: Type-                            , candidateOverlappable :: Bool-                            }-  deriving (Show, Data)--instance Free Candidate where-  freeVars' (Candidate t u _) = freeVars' (t, u)-------------------------------------------------------------------------------- * Type checking warnings (aka non-fatal errors)-------------------------------------------------------------------------------- | A non-fatal error is an error which does not prevent us from--- checking the document further and interacting with the user.--data Warning-  = NicifierIssue            DeclarationWarning-  | TerminationIssue         [TerminationError]-  | UnreachableClauses       QName [Range]-  -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs-  --   are unreachable-  | CoverageIssue            QName [(Telescope, [NamedArg DeBruijnPattern])]-  -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`-  | CoverageNoExactSplit     QName [Clause]-  | NotStrictlyPositive      QName (Seq OccursWhere)-  | UnsolvedMetaVariables    [Range]  -- ^ Do not use directly with 'warning'-  | UnsolvedInteractionMetas [Range]  -- ^ Do not use directly with 'warning'-  | UnsolvedConstraints      Constraints-    -- ^ Do not use directly with 'warning'-  | CantGeneralizeOverSorts [MetaId]-  | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern]-  | OldBuiltin               String String-    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new-  | EmptyRewritePragma-    -- ^ If the user wrote just @{-\# REWRITE \#-}@.-  | IllformedAsClause String-    -- ^ If the user wrote something other than an unqualified name-    --   in the @as@ clause of an @import@ statement.-    --   The 'String' gives optionally extra explanation.-  | ClashesViaRenaming NameOrModule [C.Name]-    -- ^ If a `renaming' import directive introduces a name or module name clash-    --   in the exported names of a module.-    --   (See issue #4154.)-  | UselessPublic-    -- ^ If the user opens a module public before the module header.-    --   (See issue #2377.)-  | UselessInline            QName-  | WrongInstanceDeclaration-  | InstanceWithExplicitArg  QName-  -- ^ An instance was declared with an implicit argument, which means it-  --   will never actually be considered by instance search.-  | InstanceNoOutputTypeName Doc-  -- ^ The type of an instance argument doesn't end in a named or-  -- variable type, so it will never be considered by instance search.-  | InstanceArgWithExplicitArg Doc-  -- ^ As InstanceWithExplicitArg, but for local bindings rather than-  --   top-level instances.-  | InversionDepthReached    QName-  -- ^ The --inversion-max-depth was reached.-  -- Generic warnings for one-off things-  | GenericWarning           Doc-    -- ^ Harmless generic warning (not an error)-  | GenericNonFatalError     Doc-    -- ^ Generic error which doesn't abort proceedings (not a warning)-  -- Safe flag errors-  | SafeFlagPostulate C.Name-  | SafeFlagPragma [String]                -- ^ Unsafe OPTIONS.-  | SafeFlagNonTerminating-  | SafeFlagTerminating-  | SafeFlagWithoutKFlagPrimEraseEquality-  | WithoutKFlagPrimEraseEquality-  | SafeFlagNoPositivityCheck-  | SafeFlagPolarity-  | SafeFlagNoUniverseCheck-  | SafeFlagNoCoverageCheck-  | SafeFlagInjective-  | SafeFlagEta                            -- ^ ETA pragma is unsafe.-  | ParseWarning             ParseWarning-  | LibraryWarning           LibWarning-  | DeprecationWarning String String String-    -- ^ `DeprecationWarning old new version`:-    --   `old` is deprecated, use `new` instead. This will be an error in Agda `version`.-  | UserWarning String-    -- ^ User-defined warning (e.g. to mention that a name is deprecated)-  | FixityInRenamingModule (NonEmpty Range)-    -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity).-  | ModuleDoesntExport C.QName [C.ImportedName]-    -- ^ Some imported names are not actually exported by the source module-  | InfectiveImport String ModuleName-    -- ^ Importing a file using an infective option into one which doesn't-  | CoInfectiveImport String ModuleName-    -- ^ Importing a file not using a coinfective option from one which does-  | RewriteNonConfluent Term Term Term Doc-    -- ^ Confluence checker found critical pair and equality checking-    --   resulted in a type error-  | RewriteMaybeNonConfluent Term Term [Doc]-    -- ^ Confluence checker got stuck on computing overlap between two-    --   rewrite rules-  | PragmaCompileErased BackendName QName-    -- ^ COMPILE directive for an erased symbol-  | NotInScopeW [C.QName]-    -- ^ Out of scope error we can recover from-  deriving (Show , Data)---warningName :: Warning -> WarningName-warningName = \case-  -- special cases-  NicifierIssue dw             -> declarationWarningName dw-  ParseWarning pw              -> parseWarningName pw-  LibraryWarning lw            -> libraryWarningName lw-  -- typechecking errors-  CantGeneralizeOverSorts{}    -> CantGeneralizeOverSorts_-  AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_-  CoverageIssue{}              -> CoverageIssue_-  CoverageNoExactSplit{}       -> CoverageNoExactSplit_-  DeprecationWarning{}         -> DeprecationWarning_-  EmptyRewritePragma           -> EmptyRewritePragma_-  IllformedAsClause{}          -> IllformedAsClause_-  WrongInstanceDeclaration{}   -> WrongInstanceDeclaration_-  InstanceWithExplicitArg{}    -> InstanceWithExplicitArg_-  InstanceNoOutputTypeName{}   -> InstanceNoOutputTypeName_-  InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_-  FixityInRenamingModule{}     -> FixityInRenamingModule_-  GenericNonFatalError{}       -> GenericNonFatalError_-  GenericWarning{}             -> GenericWarning_-  InversionDepthReached{}      -> InversionDepthReached_-  ModuleDoesntExport{}         -> ModuleDoesntExport_-  NotInScopeW{}                -> NotInScope_-  NotStrictlyPositive{}        -> NotStrictlyPositive_-  OldBuiltin{}                 -> OldBuiltin_-  SafeFlagNoPositivityCheck    -> SafeFlagNoPositivityCheck_-  SafeFlagNonTerminating       -> SafeFlagNonTerminating_-  SafeFlagNoUniverseCheck      -> SafeFlagNoUniverseCheck_-  SafeFlagPolarity             -> SafeFlagPolarity_-  SafeFlagPostulate{}          -> SafeFlagPostulate_-  SafeFlagPragma{}             -> SafeFlagPragma_-  SafeFlagEta                  -> SafeFlagEta_-  SafeFlagInjective            -> SafeFlagInjective_-  SafeFlagNoCoverageCheck      -> SafeFlagNoCoverageCheck_-  SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_-  WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_-  SafeFlagTerminating          -> SafeFlagTerminating_-  TerminationIssue{}           -> TerminationIssue_-  UnreachableClauses{}         -> UnreachableClauses_-  UnsolvedInteractionMetas{}   -> UnsolvedInteractionMetas_-  UnsolvedConstraints{}        -> UnsolvedConstraints_-  UnsolvedMetaVariables{}      -> UnsolvedMetaVariables_-  UselessInline{}              -> UselessInline_-  UselessPublic{}              -> UselessPublic_-  ClashesViaRenaming{}         -> ClashesViaRenaming_-  UserWarning{}                -> UserWarning_-  InfectiveImport{}            -> InfectiveImport_-  CoInfectiveImport{}          -> CoInfectiveImport_-  RewriteNonConfluent{}        -> RewriteNonConfluent_-  RewriteMaybeNonConfluent{}   -> RewriteMaybeNonConfluent_-  PragmaCompileErased{}        -> PragmaCompileErased_--data TCWarning-  = TCWarning-    { tcWarningRange :: Range-        -- ^ Range where the warning was raised-    , tcWarning   :: Warning-        -- ^ The warning itself-    , tcWarningPrintedWarning :: Doc-        -- ^ The warning printed in the state and environment where it was raised-    , tcWarningCached :: Bool-        -- ^ Should the warning be affected by caching.-    }-  deriving Show---tcWarningOrigin :: TCWarning -> SrcFile-tcWarningOrigin = rangeFile . tcWarningRange--instance HasRange TCWarning where-  getRange = tcWarningRange---- used for merging lists of warnings-instance Eq TCWarning where-  (==) = (==) `on` tcWarningPrintedWarning-------------------------------------------------------------------------------- * Type checking errors-------------------------------------------------------------------------------- | Information about a call.--data CallInfo = CallInfo-  { callInfoTarget :: QName-    -- ^ Target function name.-  , callInfoRange :: Range-    -- ^ Range of the target function.-  , callInfoCall :: Closure Term-    -- ^ To be formatted representation of the call.-  } deriving (Data, Show)---- no Eq, Ord instances: too expensive! (see issues 851, 852)---- | We only 'show' the name of the callee.-instance Pretty CallInfo where pretty = pretty . callInfoTarget-instance AllNames CallInfo where allNames = singleton . callInfoTarget---- UNUSED, but keep!--- -- | Call pathes are sequences of 'CallInfo's starting from a 'callSource'.--- data CallPath = CallPath---   { callSource :: QName---     -- ^ The originator of the first call.---   , callInfos :: [CallInfo]---     -- ^ The calls, in order from source to final target.---   }---   deriving (Show)---- -- | 'CallPath'es can be connected, but there is no empty callpath.--- --   Thus, they form a semigroup, but we choose to abuse 'Monoid'.--- instance Monoid CallPath where---   mempty = __IMPOSSIBLE__---   mappend (CallPath src cs) (CallPath _ cs') = CallPath src $ cs ++ cs'---- | Information about a mutual block which did not pass the--- termination checker.--data TerminationError = TerminationError-  { termErrFunctions :: [QName]-    -- ^ The functions which failed to check. (May not include-    -- automatically generated functions.)-  , termErrCalls :: [CallInfo]-    -- ^ The problematic call sites.-  } deriving (Data, Show)---- | Error when splitting a pattern variable into possible constructor patterns.-data SplitError-  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.-  | IrrelevantDatatype  (Closure Type)  -- ^ Data type, but in irrelevant position.-  | ErasedDatatype Bool (Closure Type)  -- ^ Data type, but in erased position.-                                        --   If the boolean is 'True',-                                        --   then the reason for the-                                        --   error is that the K rule-                                        --   is turned off.-  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.-  -- UNUSED, but keep!-  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor-  | UnificationStuck-    { 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)--data NegativeUnification-  = UnifyConflict Telescope Term Term-  | UnifyCycle Telescope Int Term-  deriving (Show)--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)--data UnquoteError-  = BadVisibility String (Arg I.Term)-  | ConInsteadOfDef QName String String-  | DefInsteadOfCon QName String String-  | NonCanonical String I.Term-  | BlockedOnMeta TCState MetaId-  | UnquotePanic String-  deriving (Show)--data TypeError-        = InternalError String-        | NotImplemented String-        | NotSupported String-        | CompilationError String-        | PropMustBeSingleton-        | DataMustEndInSort Term-{- UNUSED-        | DataTooManyParameters-            -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the-            --   the parameters given in the forward declaraion @data D Gamma : T@.--}-        | ShouldEndInApplicationOfTheDatatype Type-            -- ^ The target of a constructor isn't an application of its-            -- datatype. The 'Type' records what it does target.-        | ShouldBeAppliedToTheDatatypeParameters Term Term-            -- ^ The target of a constructor isn't its datatype applied to-            --   something that isn't the parameters. First term is the correct-            --   target and the second term is the actual target.-        | ShouldBeApplicationOf Type QName-            -- ^ Expected a type to be an application of a particular datatype.-        | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype-        | CantResolveOverloadedConstructorsTargetingSameDatatype QName [QName]-          -- ^ Datatype, constructors.-        | DoesNotConstructAnElementOf QName Type -- ^ constructor, type-        | WrongHidingInLHS-            -- ^ The left hand side of a function definition has a hidden argument-            --   where a non-hidden was expected.-        | WrongHidingInLambda Type-            -- ^ Expected a non-hidden function and found a hidden lambda.-        | WrongHidingInApplication Type-            -- ^ A function is applied to a hidden argument where a non-hidden was expected.-        | WrongNamedArgument (NamedArg A.Expr) [NamedName]-            -- ^ A function is applied to a hidden named argument it does not have.-            -- The list contains names of possible hidden arguments at this point.-        | WrongIrrelevanceInLambda-            -- ^ Wrong user-given relevance annotation in lambda.-        | WrongQuantityInLambda-            -- ^ Wrong user-given quantity annotation in lambda.-        | WrongCohesionInLambda-            -- ^ Wrong user-given cohesion annotation in lambda.-        | QuantityMismatch Quantity Quantity-            -- ^ The given quantity does not correspond to the expected quantity.-        | HidingMismatch Hiding Hiding-            -- ^ The given hiding does not correspond to the expected hiding.-        | RelevanceMismatch Relevance Relevance-            -- ^ The given relevance does not correspond to the expected relevane.-        | UninstantiatedDotPattern A.Expr-        | ForcedConstructorNotInstantiated A.Pattern-        | IlltypedPattern A.Pattern Type-        | IllformedProjectionPattern A.Pattern-        | CannotEliminateWithPattern (NamedArg A.Pattern) Type-        | WrongNumberOfConstructorArguments QName Nat Nat-        | ShouldBeEmpty Type [DeBruijnPattern]-        | ShouldBeASort Type-            -- ^ The given type should have been a sort.-        | ShouldBePi Type-            -- ^ The given type should have been a pi.-        | ShouldBePath Type-        | ShouldBeRecordType Type-        | ShouldBeRecordPattern DeBruijnPattern-        | NotAProjectionPattern (NamedArg A.Pattern)-        | NotAProperTerm-        | InvalidTypeSort Sort-            -- ^ This sort is not a type expression.-        | InvalidType Term-            -- ^ This term is not a type expression.-        | FunctionTypeInSizeUniv Term-            -- ^ This term, a function type constructor, lives in-            --   @SizeUniv@, which is not allowed.-        | SplitOnIrrelevant (Dom Type)-        | SplitOnUnusableCohesion (Dom Type)-        -- UNUSED: -- | SplitOnErased (Dom Type)-        | SplitOnNonVariable Term Type-        | DefinitionIsIrrelevant QName-        | DefinitionIsErased QName-        | VariableIsIrrelevant Name-        | VariableIsErased Name-        | VariableIsOfUnusableCohesion Name Cohesion-        | UnequalLevel Comparison Level Level-        | UnequalTerms Comparison Term Term CompareAs-        | UnequalTypes Comparison Type Type---      | UnequalTelescopes Comparison Telescope Telescope -- UNUSED-        | UnequalRelevance Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalQuantity Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalCohesion Comparison Term Term-            -- ^ The two function types have different cohesion.-        | UnequalHiding Term Term-            -- ^ The two function types have different hiding.-        | UnequalSorts Sort Sort-        | UnequalBecauseOfUniverseConflict Comparison Term Term-        | NotLeqSort Sort Sort-        | MetaCannotDependOn MetaId Nat-            -- ^ The arguments are the meta variable and the parameter that it wants to depend on.-        | MetaOccursInItself MetaId-        | MetaIrrelevantSolution MetaId Term-        | MetaErasedSolution MetaId Term-        | GenericError String-        | GenericDocError Doc-        | BuiltinMustBeConstructor String A.Expr-        | NoSuchBuiltinName String-        | DuplicateBuiltinBinding String Term Term-        | NoBindingForBuiltin String-        | NoSuchPrimitiveFunction String-        | DuplicatePrimitiveBinding String QName QName-        | ShadowedModule C.Name [A.ModuleName]-        | BuiltinInParameterisedModule String-        | IllegalLetInTelescope C.TypedBinding-        | IllegalPatternInTelescope C.Binder-        | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]-        | TooManyFields QName [C.Name] [C.Name]-          -- ^ Record type, fields not supplied by user, non-fields not supplied.-        | DuplicateFields [C.Name]-        | DuplicateConstructors [C.Name]-        | WithOnFreeVariable A.Expr Term-        | UnexpectedWithPatterns [A.Pattern]-        | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)-        | FieldOutsideRecord-        | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]-        | GeneralizeCyclicDependency-        | GeneralizeUnsolvedMeta-    -- Coverage errors--- UNUSED:        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off-        | SplitError SplitError-        | ImpossibleConstructor QName NegativeUnification-    -- Positivity errors-        | TooManyPolarities QName Int-    -- Import errors-        | LocalVsImportedModuleClash ModuleName-        | SolvedButOpenHoles-          -- ^ Some interaction points (holes) have not been filled by user.-          --   There are not 'UnsolvedMetas' since unification solved them.-          --   This is an error, since interaction points are never filled-          --   without user interaction.-        | CyclicModuleDependency [C.TopLevelModuleName]-        | FileNotFound C.TopLevelModuleName [AbsolutePath]-        | OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName-        | AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath]-        | ModuleNameUnexpected C.TopLevelModuleName C.TopLevelModuleName-          -- ^ Found module name, expected module name.-        | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]-        | ClashingFileNamesFor ModuleName [AbsolutePath]-        | ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath-          -- ^ Module name, file from which it was loaded, file which-          -- the include path says contains the module.-    -- Scope errors-        | BothWithAndRHS-        | AbstractConstructorNotInScope A.QName-        | NotInScope [C.QName]-        | NoSuchModule C.QName-        | AmbiguousName C.QName (NonEmpty A.QName)-        | AmbiguousModule C.QName (NonEmpty A.ModuleName)-        | ClashingDefinition C.QName A.QName-        | ClashingModule A.ModuleName A.ModuleName-        | ClashingImport C.Name A.QName-        | ClashingModuleImport C.Name A.ModuleName-        | PatternShadowsConstructor C.Name A.QName-        | DuplicateImports C.QName [C.ImportedName]-        | InvalidPattern C.Pattern-        | RepeatedVariablesInPattern [C.Name]-        | GeneralizeNotSupportedHere A.QName-        | MultipleFixityDecls [(C.Name, [Fixity'])]-        | MultiplePolarityPragmas [C.Name]-    -- Concrete to Abstract errors-        | NotAModuleExpr C.Expr-            -- ^ The expr was used in the right hand side of an implicit module-            --   definition, but it wasn't of the form @m Delta@.-        | NotAnExpression C.Expr-        | NotAValidLetBinding NiceDeclaration-        | NotValidBeforeField NiceDeclaration-        | NothingAppliedToHiddenArg C.Expr-        | NothingAppliedToInstanceArg C.Expr-    -- Pattern synonym errors-        | BadArgumentsToPatternSynonym A.AmbiguousQName-        | TooFewArgumentsToPatternSynonym A.AmbiguousQName-        | CannotResolveAmbiguousPatternSynonym (NonEmpty (A.QName, A.PatternSynDefn))-        | UnusedVariableInPatternSynonym-    -- Operator errors-        | NoParseForApplication [C.Expr]-        | AmbiguousParseForApplication [C.Expr] [C.Expr]-        | NoParseForLHS LHSOrPatSyn C.Pattern-        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]-        | OperatorInformation [NotationSection] TypeError-{- UNUSED-        | NoParseForPatternSynonym C.Pattern-        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]--}-    -- Usage errors-    -- Instance search errors-        | InstanceNoCandidate Type [(Term, TCErr)]-    -- Reflection errors-        | UnquoteFailed UnquoteError-        | DeBruijnIndexOutOfScope Nat Telescope [Name]-    -- Language option errors-        | NeedOptionCopatterns-        | NeedOptionRewriting-        | NeedOptionProp-    -- Failure associated to warnings-        | NonFatalErrors [TCWarning]-    -- Instance search errors-        | InstanceSearchDepthExhausted Term Type Int-        | TriedToCopyConstrainedPrim QName-          deriving Show---- | Distinguish error message when parsing lhs or pattern synonym, resp.-data LHSOrPatSyn = IsLHS | IsPatSyn deriving (Eq, Show)---- | Type-checking errors.--data TCErr-  = TypeError-    { tcErrState   :: TCState-        -- ^ The state in which the error was raised.-    , tcErrClosErr :: Closure TypeError-        -- ^ The environment in which the error as raised plus the error.-    }-  | Exception Range Doc-  | IOException TCState Range E.IOException-    -- ^ The first argument is the state in which the error was-    -- raised.-  | PatternErr-      -- ^ The exception which is usually caught.-      --   Raised for pattern violations during unification ('assignV')-      --   but also in other situations where we want to backtrack.--instance Error TCErr where-  strMsg = Exception noRange . text . strMsg--instance Show TCErr where-  show (TypeError _ e)     = show (envRange $ clEnv e) ++ ": " ++ show (clValue e)-  show (Exception r d)     = show r ++ ": " ++ render d-  show (IOException _ r e) = show r ++ ": " ++ show e-  show PatternErr{}        = "Pattern violation (you shouldn't see this)"--instance HasRange TCErr where-  getRange (TypeError _ cl)    = envRange $ clEnv cl-  getRange (Exception r _)     = r-  getRange (IOException s r _) = r-  getRange PatternErr{}        = noRange--instance E.Exception TCErr---------------------------------------------------------------------------------- * Accessing options--------------------------------------------------------------------------------class (Functor m, Applicative m, Monad m) => HasOptions m where-  -- | Returns the pragma options which are currently in effect.-  pragmaOptions      :: m PragmaOptions-  -- | Returns the command line options which are currently in effect.-  commandLineOptions :: m CommandLineOptions--  default pragmaOptions :: (HasOptions n, MonadTrans t, m ~ t n) => m PragmaOptions-  pragmaOptions      = lift pragmaOptions--  default commandLineOptions :: (HasOptions n, MonadTrans t, m ~ t n) => m CommandLineOptions-  commandLineOptions = lift commandLineOptions--instance MonadIO m => HasOptions (TCMT m) where-  pragmaOptions = useTC stPragmaOptions--  commandLineOptions = do-    p  <- useTC stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> getTC-    return $ cl { optPragmaOptions = p }---- HasOptions lifts through monad transformers--- (see default signatures in the HasOptions class).--instance HasOptions m => HasOptions (ChangeT m)-instance HasOptions m => HasOptions (ExceptT e m)-instance HasOptions m => HasOptions (IdentityT m)-instance HasOptions m => HasOptions (ListT m)-instance HasOptions m => HasOptions (MaybeT m)-instance HasOptions m => HasOptions (ReaderT r m)-instance HasOptions m => HasOptions (StateT s m)-instance (HasOptions m, Monoid w) => HasOptions (WriterT w m)---- Ternary options are annoying to deal with so we provide auxiliary--- definitions using @collapseDefault@.--sizedTypesOption :: HasOptions m => m Bool-sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions--guardednessOption :: HasOptions m => m Bool-guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions--withoutKOption :: HasOptions m => m Bool-withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions---- | Gets the include directories.------ Precondition: 'optAbsoluteIncludePaths' must be nonempty (i.e.--- 'setCommandLineOptions' must have run).--getIncludeDirs :: HasOptions m => m [AbsolutePath]-getIncludeDirs = do-  incs <- optAbsoluteIncludePaths <$> commandLineOptions-  case incs of-    [] -> __IMPOSSIBLE__-    _  -> return incs--enableCaching :: HasOptions m => m Bool-enableCaching = optCaching <$> pragmaOptions--------------------------------------------------------------------------------- * The reduce monad---------------------------------------------------------------------------------- | Environment of the reduce monad.-data ReduceEnv = ReduceEnv-  { redEnv :: TCEnv    -- ^ Read only access to environment.-  , redSt  :: TCState  -- ^ Read only access to state (signature, metas...).-  }--mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv-mapRedEnv f s = s { redEnv = f (redEnv s) }--mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv-mapRedSt f s = s { redSt = f (redSt s) }--mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv-            -> ReduceEnv-mapRedEnvSt f g (ReduceEnv e s) = ReduceEnv (f e) (g s)---- Lenses-reduceEnv :: Lens' TCEnv ReduceEnv-reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }--reduceSt :: Lens' TCState ReduceEnv-reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }--newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }---  deriving (Functor, Applicative, Monad)--onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-onReduceEnv f (ReduceM m) = ReduceM (m . f)--fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b-fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e-{-# INLINE fmapReduce #-}--apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b-apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e -> f e $! x e-{-# INLINE apReduce #-}--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--instance Monad ReduceM where-  return = pure-  (>>=) = bindReduce-  (>>) = (*>)-#if __GLASGOW_HASKELL__ < 808-  fail = Fail.fail-#endif--instance Fail.MonadFail ReduceM where-  fail = error--instance ReadTCState ReduceM where-  getTCState = ReduceM redSt-  locallyTCState l f = onReduceEnv $ mapRedSt $ over l f--runReduceM :: ReduceM a -> TCM a-runReduceM m = do-  e <- askTC-  s <- getTC-  return $! unReduceM m (ReduceEnv e s)--runReduceF :: (a -> ReduceM b) -> TCM (a -> b)-runReduceF f = do-  e <- askTC-  s <- getTC-  return $ \x -> unReduceM (f x) (ReduceEnv e s)--instance MonadTCEnv ReduceM where-  askTC   = ReduceM redEnv-  localTC = onReduceEnv . mapRedEnv---- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084):------   useR forces the result of projecting the lens,---   this usually prevents retaining the whole structure when we only need a field.------ This fixes (or contributes to the fix of) the space leak issue #1829 (caching).-useR :: (ReadTCState m) => Lens' a TCState -> m a-useR l = do-  !x <- (^.l) <$> getTCState-  return x--askR :: ReduceM ReduceEnv-askR = ReduceM ask--localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-localR f = ReduceM . local f . unReduceM--instance HasOptions ReduceM where-  pragmaOptions      = useR stPragmaOptions-  commandLineOptions = do-    p  <- useR stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> getTCState-    return $ cl{ optPragmaOptions = p }--class ( Applicative m-      , MonadTCEnv m-      , ReadTCState m-      , HasOptions m-      ) => MonadReduce m where-  liftReduce :: ReduceM a -> m a--instance MonadReduce m => MonadReduce (MaybeT m) where-  liftReduce = lift . liftReduce--instance MonadReduce m => MonadReduce (ListT m) where-  liftReduce = lift . liftReduce--instance MonadReduce m => MonadReduce (ExceptT err m) where-  liftReduce = lift . liftReduce--instance MonadReduce m => MonadReduce (ReaderT r m) where-  liftReduce = lift . liftReduce--instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m) where-  liftReduce = lift . liftReduce--instance MonadReduce m => MonadReduce (StateT w m) where-  liftReduce = lift . liftReduce--instance MonadReduce ReduceM where-  liftReduce = id-------------------------------------------------------------------------------- * 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--instance MonadTCEnv m => MonadTCEnv (MaybeT m) where-  askTC   = lift askTC-  localTC = mapMaybeT . localTC--instance MonadTCEnv m => MonadTCEnv (ListT m) where-  askTC   = lift askTC-  localTC = mapListT . localTC--instance MonadTCEnv m => MonadTCEnv (ExceptT err m) where-  askTC   = lift askTC-  localTC = mapExceptT . localTC--instance MonadTCEnv m => MonadTCEnv (ReaderT r m) where-  askTC   = lift askTC-  localTC = mapReaderT . localTC--instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m) where-  askTC   = lift askTC-  localTC = mapWriterT . localTC--instance MonadTCEnv m => MonadTCEnv (StateT s m) where-  askTC   = lift askTC-  localTC = mapStateT . localTC--instance MonadTCEnv m => MonadTCEnv (ChangeT m) where-  askTC   = lift askTC-  localTC = mapChangeT . localTC--instance MonadTCEnv m => MonadTCEnv (IdentityT m) where-  askTC   = lift askTC-  localTC = mapIdentityT . localTC--asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a-asksTC f = f <$> askTC--viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a-viewTC l = asksTC (^. l)---- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.-locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b-locallyTC l = localTC . over l-------------------------------------------------------------------------------- * Monad with mutable 'TCState'-------------------------------------------------------------------------------- | @MonadTCState@ made into its own dedicated service class.---   This allows us to use 'MonadState' for 'StateT' extensions of @TCM@.-class Monad m => MonadTCState m where-  getTC :: m TCState-  putTC :: TCState -> m ()-  modifyTC :: (TCState -> TCState) -> m ()--  {-# MINIMAL getTC, (putTC | modifyTC) #-}-  putTC      = modifyTC . const-  modifyTC f = putTC . f =<< getTC--instance MonadTCState m => MonadTCState (MaybeT m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (ListT m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (ExceptT err m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (ReaderT r m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (StateT s m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (ChangeT m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (IdentityT m) where-  getTC    = lift getTC-  putTC    = lift . putTC-  modifyTC = lift . modifyTC---- ** @TCState@ accessors (no lenses)--getsTC :: ReadTCState m => (TCState -> a) -> m a-getsTC f = f <$> getTCState---- | A variant of 'modifyTC' in which the computation is strict in the--- new state.-modifyTC' :: MonadTCState m => (TCState -> TCState) -> m ()-modifyTC' f = do-  s' <- getTC-  putTC $! f s'---- SEE TC.Monad.State--- -- | Restore the 'TCState' after computation.--- localTCState :: MonadTCState m => m a -> m a--- localTCState = bracket_ getTC putTC---- ** @TCState@ accessors via lenses--useTC :: ReadTCState m => Lens' a TCState -> m a-useTC l = do-  !x <- getsTC (^. l)-  return x--infix 4 `setTCLens`---- | Overwrite the part of the 'TCState' focused on by the lens.-setTCLens :: MonadTCState m => Lens' a TCState -> a -> m ()-setTCLens l = modifyTC . set l---- | Modify the part of the 'TCState' focused on by the lens.-modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()-modifyTCLens l = modifyTC . over l---- | Modify a part of the state monadically.-modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m ()-modifyTCLensM l f = putTC =<< l f =<< getTC---- | Modify the part of the 'TCState' focused on by the lens, and return some result.-stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r-stateTCLens l f = stateTCLensM l $ return . f---- | Modify a part of the state monadically, and return some result.-stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r-stateTCLensM l f = do-  s <- getTC-  (result , x) <- f $ s ^. l-  putTC $ set l x s-  return result-------------------------------------------------------------------------------- * Type checking monad transformer-------------------------------------------------------------------------------- | The type checking monad transformer.--- Adds readonly 'TCEnv' and mutable 'TCState'.-newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }---- | Type checking monad.-type TCM = TCMT IO--{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}-mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a-mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e)--pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a-pureTCM f = TCM $ \ r e -> do-  s <- liftIO $ readIORef r-  return (f s e)---- One goal of the definitions and pragmas below is to inline the--- monad operations as much as possible. This doesn't seem to have a--- large effect on the performance of the normal executable, but (at--- least on one machine/configuration) it has a massive effect on the--- performance of the profiling executable [1], and reduces the time--- attributed to bind from over 90% to about 25%.------ [1] When compiled with -auto-all and run with -p: roughly 750%--- faster for one example.--returnTCMT :: MonadIO m => a -> TCMT m a-returnTCMT = \x -> TCM $ \_ _ -> return x-{-# INLINE returnTCMT #-}--bindTCMT :: MonadIO 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 :: MonadIO 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 MonadIO m => Functor (TCMT m) where-  fmap = fmapTCMT--fmapTCMT :: MonadIO m => (a -> b) -> TCMT m a -> TCMT m b-fmapTCMT = \f (TCM m) -> TCM $ \r e -> liftM f (m r e)-{-# INLINE fmapTCMT #-}--instance MonadIO m => Applicative (TCMT m) where-  pure  = returnTCMT-  (<*>) = apTCMT--apTCMT :: MonadIO m => TCMT m (a -> b) -> TCMT m a -> TCMT m b-apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> ap (mf r e) (m r e)-{-# INLINE apTCMT #-}--instance MonadTrans TCMT where-    lift m = TCM $ \_ _ -> m---- We want a special monad implementation of fail.-instance MonadIO m => Monad (TCMT m) where-    return = pure-    (>>=)  = bindTCMT-    (>>)   = (*>)-#if __GLASGOW_HASKELL__ < 808-    fail   = Fail.fail-#endif--instance MonadIO m => Fail.MonadFail (TCMT m) where-  fail = internalError--instance MonadIO m => MonadIO (TCMT m) where-  liftIO m = TCM $ \ s env -> do-    liftIO $ wrap s (envRange env) $ do-      x <- m-      x `seq` return x-    where-      wrap s r m = E.catch m $ \ err -> do-        s <- readIORef s-        E.throwIO $ IOException s r err--instance MonadIO m => MonadTCEnv (TCMT m) where-  askTC             = TCM $ \ _ e -> return e-  localTC f (TCM m) = TCM $ \ s e -> m s (f e)--instance MonadIO m => MonadTCState (TCMT m) where-  getTC   = TCM $ \ r _e -> liftIO (readIORef r)-  putTC s = TCM $ \ r _e -> liftIO (writeIORef r s)--instance MonadIO m => ReadTCState (TCMT m) where-  getTCState = getTC-  locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l)--instance MonadError TCErr TCM where-  throwError = liftIO . E.throwIO-  catchError m h = TCM $ \ r e -> do  -- now we are in the IO monad-    oldState <- readIORef r-    unTCM m r e `E.catch` \err -> do-      -- Reset the state, but do not forget changes to the persistent-      -- component. Not for pattern violations.-      case err of-        PatternErr -> return ()-        _          ->-          liftIO $ do-            newState <- readIORef r-            writeIORef r $ oldState { stPersistentState = stPersistentState newState }-      unTCM (h err) r e---- | Like 'catchError', but resets the state completely before running the handler.---   This means it also loses changes to the 'stPersistentState'.------   The intended use is to catch internal errors during debug printing.---   In debug printing, we are not expecting state changes.-instance CatchImpossible TCM where-  catchImpossibleJust f m h = TCM $ \ r e -> do-    -- save the state-    s <- readIORef r-    catchImpossibleJust f (unTCM m r e) $ \ err -> do-      writeIORef r s-      unTCM (h err) r e--instance MonadIO m => MonadReduce (TCMT m) where-  liftReduce = liftTCM . runReduceM--instance (IsString a, MonadIO m) => IsString (TCMT m a) where-  fromString s = return (fromString s)---- | Strict (non-shortcut) semigroup.------   Note that there might be a lazy alternative, e.g.,---   for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation,---   to shortcut conjunction in case we already have 'False'.----instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where-  (<>) = liftA2 (<>)---- | Strict (non-shortcut) monoid.-instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where-  mempty  = pure mempty-  mappend = (<>)-  mconcat = mconcat <.> sequence---- | Interaction monad.--type IM = TCMT (Haskeline.InputT IO)--runIM :: IM a -> TCM a-runIM = mapTCMT (Haskeline.runInputT Haskeline.defaultSettings)--instance MonadError TCErr IM where-  throwError     = liftIO . E.throwIO-  catchError m h = liftTCM $ runIM m `catchError` (runIM . h)---- | Preserve the state of the failing computation.-catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a-catchError_ m h = TCM $ \r e ->-  unTCM m r e-  `E.catch` \err -> unTCM (h err) r e---- | Execute a finalizer even when an exception is thrown.---   Does not catch any errors.---   In case both the regular computation and the finalizer---   throw an exception, the one of the finalizer is propagated.-finally_ :: TCM a -> TCM b -> TCM a-finally_ m f = do-    x <- m `catchError_` \ err -> f >> throwError err-    _ <- f-    return x---- | Embedding a TCM computation.--class ( Applicative tcm, MonadIO tcm-      , MonadTCEnv tcm-      , MonadTCState tcm-      , HasOptions tcm-      ) => MonadTCM tcm where-    liftTCM :: TCM a -> tcm a--    default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a-    liftTCM = lift . liftTCM--{-# RULES "liftTCM/id" liftTCM = id #-}-instance MonadIO m => MonadTCM (TCMT m) where-    liftTCM = mapTCMT liftIO--instance MonadTCM tcm => MonadTCM (ChangeT tcm)-instance MonadTCM tcm => MonadTCM (ExceptT err tcm)-instance MonadTCM tcm => MonadTCM (IdentityT tcm)-instance MonadTCM tcm => MonadTCM (ListT tcm)-instance MonadTCM tcm => MonadTCM (MaybeT tcm)-instance MonadTCM tcm => MonadTCM (ReaderT r tcm)-instance MonadTCM tcm => MonadTCM (StateT s tcm)-instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm)---- | We store benchmark statistics in an IORef.---   This enables benchmarking pure computation, see---   "Agda.Benchmarking".-instance MonadBench Phase TCM where-  getBenchmark = liftIO $ getBenchmark-  putBenchmark = liftIO . putBenchmark-  finally = finally_--instance Null (TCM Doc) where-  empty = return empty-  null = __IMPOSSIBLE__--patternViolation :: MonadError TCErr m => m a-patternViolation = throwError PatternErr--internalError :: MonadTCM tcm => String -> tcm a-internalError s = liftTCM $ typeError $ InternalError s--genericError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m)-             => String -> m a-genericError = typeError . GenericError--{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}-genericDocError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m)-                => Doc -> m a-genericDocError = typeError . GenericDocError--{-# SPECIALIZE typeError :: TypeError -> TCM a #-}-typeError :: (MonadTCEnv m, ReadTCState m, MonadError TCErr m)-          => TypeError -> m a-typeError err = throwError =<< typeError_ err--{-# SPECIALIZE typeError_ :: TypeError -> TCM TCErr #-}-typeError_ :: (MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr-typeError_ err = TypeError <$> getTCState <*> buildClosure err---- | Running the type checking monad (most general form).-{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}-runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)-runTCM e s m = do-  r <- liftIO $ newIORef s-  a <- unTCM m r e-  s <- liftIO $ readIORef r-  return (a, s)---- | Running the type checking monad on toplevel (with initial state).-runTCMTop :: TCM a -> IO (Either TCErr a)-runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left)--runTCMTop' :: MonadIO m => TCMT m a -> m a-runTCMTop' m = do-  r <- liftIO $ newIORef initState-  unTCM m r initEnv---- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which cannot fail)---   in the initial environment.--runSafeTCM :: TCM a -> TCState -> IO (a, TCState)-runSafeTCM m st = runTCM initEnv st m `E.catch` (\ (e :: TCErr) -> __IMPOSSIBLE__)--- runSafeTCM m st = either__IMPOSSIBLE__ return <$> do---     -- Errors must be impossible.---     runTCM $ do---         putTC st---         a <- m---         st <- getTC---         return (a, st)---- | Runs the given computation in a separate thread, with /a copy/ of--- the current state and environment.------ Note that Agda sometimes uses actual, mutable state. If the--- computation given to @forkTCM@ tries to /modify/ this state, then--- bad things can happen, because accesses are not mutually exclusive.--- The @forkTCM@ function has been added mainly to allow the thread to--- /read/ (a snapshot of) the current state in a convenient way.------ Note also that exceptions which are raised in the thread are not--- propagated to the parent, so the thread should not do anything--- important.--forkTCM :: TCM a -> TCM ()-forkTCM m = do-  s <- getTC-  e <- askTC-  liftIO $ void $ C.forkIO $ void $ runTCM e s m-------------------------------------------------------------------------------- * Names for generated definitions-------------------------------------------------------------------------------- | Base name for patterns in telescopes-patternInTeleName :: String-patternInTeleName = ".patternInTele"---- | Base name for extended lambda patterns-extendedLambdaName :: String-extendedLambdaName = ".extendedlambda"---- | Check whether we have an definition from an extended lambda.-isExtendedLambdaName :: A.QName -> Bool-isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName---- | Name of absurdLambda definitions.-absurdLambdaName :: String-absurdLambdaName = ".absurdlambda"---- | Check whether we have an definition from an absurd lambda.-isAbsurdLambdaName :: QName -> Bool-isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName---- | Base name for generalized variable projections-generalizedFieldName :: String-generalizedFieldName = ".generalizedField-"---- | Check whether we have a generalized variable field-getGeneralizedFieldName :: A.QName -> Maybe String-getGeneralizedFieldName q-  | List.isPrefixOf generalizedFieldName strName = Just (drop (length generalizedFieldName) strName)-  | otherwise                                    = Nothing-  where strName = prettyShow $ nameConcrete $ qnameName q-------------------------------------------------------------------------------- * KillRange instances------------------------------------------------------------------------------instance KillRange Signature where-  killRange (Sig secs defs rews) = killRange2 Sig secs defs rews--instance KillRange Sections where-  killRange = fmap killRange--instance KillRange Definitions where-  killRange = fmap killRange--instance KillRange RewriteRuleMap where-  killRange = fmap killRange--instance KillRange Section where-  killRange (Section tel) = killRange1 Section tel--instance KillRange Definition where-  killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk def) =-    killRange18 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk def-    -- TODO clarify: Keep the range in the defName field?--instance KillRange NumGeneralizableArgs where-  killRange = id--instance KillRange NLPat where-  killRange (PVar x y) = killRange2 PVar x y-  killRange (PDef x y) = killRange2 PDef x y-  killRange (PLam x y) = killRange2 PLam x y-  killRange (PPi x y)  = killRange2 PPi x y-  killRange (PSort x)  = killRange1 PSort x-  killRange (PBoundVar x y) = killRange2 PBoundVar x y-  killRange (PTerm x)  = killRange1 PTerm x--instance KillRange NLPType where-  killRange (NLPType s a) = killRange2 NLPType s a--instance KillRange NLPSort where-  killRange (PType l) = killRange1 PType l-  killRange (PProp l) = killRange1 PProp l-  killRange PInf      = PInf-  killRange PSizeUniv = PSizeUniv--instance KillRange RewriteRule where-  killRange (RewriteRule q gamma f es rhs t) =-    killRange6 RewriteRule q gamma f es rhs t--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 sys) = killRange2 ExtLamInfo m sys--instance KillRange FunctionFlag where-  killRange = id--instance KillRange CompKit where-  killRange = id--instance KillRange Defn where-  killRange def =-    case def of-      Axiom -> Axiom-      DataOrRecSig n -> DataOrRecSig n-      GeneralizableVar -> GeneralizableVar-      AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!-      Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with ->-        killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with-      Datatype a b c d e f g h       -> killRange7 Datatype a b c d e f g h-      Record a b c d e f g h i j k   -> killRange11 Record a b c d e f g h i j k-      Constructor a b c d e f g h i j-> killRange10 Constructor a b c d e f g h i j-      Primitive a b c d e            -> killRange5 Primitive a b c d e--instance KillRange MutualId where-  killRange = id--instance KillRange c => KillRange (FunctionInverse' c) where-  killRange NotInjective = NotInjective-  killRange (Inverse m)  = Inverse $ killRangeMap m--instance KillRange TermHead where-  killRange SortHead     = SortHead-  killRange PiHead       = PiHead-  killRange (ConsHead q) = ConsHead $ killRange q-  killRange h@VarHead{}  = h-  killRange UnknownHead  = UnknownHead--instance KillRange Projection where-  killRange (Projection a b c d e) = killRange5 Projection a b c d e--instance KillRange ProjLams where-  killRange = id--instance KillRange a => KillRange (Open a) where-  killRange = fmap killRange--instance KillRange DisplayForm where-  killRange (Display n es dt) = killRange3 Display n es dt--instance KillRange Polarity where-  killRange = id--instance KillRange IsForced where-  killRange = id--instance KillRange DoGeneralize where-  killRange = id--instance KillRange DisplayTerm where-  killRange dt =-    case dt of-      DWithApp dt dts es -> killRange3 DWithApp dt dts es-      DCon q ci dts     -> killRange3 DCon q ci dts-      DDef q dts        -> killRange2 DDef q dts-      DDot v            -> killRange1 DDot v-      DTerm v           -> killRange1 DTerm v--instance KillRange a => KillRange (Closure a) where-  killRange = id+{-# LANGUAGE CPP #-}+-- {-# LANGUAGE UndecidableInstances #-}  -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT++module Agda.TypeChecking.Monad.Base+  ( module Agda.TypeChecking.Monad.Base+  , HasOptions (..)+  ) where++import Prelude hiding (null)++import Control.Applicative hiding (empty)+import qualified Control.Concurrent as C+import Control.DeepSeq+import qualified Control.Exception as E++import qualified Control.Monad.Fail as Fail++import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Writer hiding ((<>))+import Control.Monad.Trans          ( MonadTrans(..), lift )+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe++import Control.Parallel             ( pseq )++import Data.Array (Ix)+import Data.Function+import Data.Int+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map -- hiding (singleton, null, empty)+import Data.Sequence (Seq)+import Data.Set (Set)+import qualified Data.Set as Set -- hiding (singleton, null, empty)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )+import Data.Data (Data)+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Data.IORef++import GHC.Generics (Generic)++import Agda.Benchmarking (Benchmark, Phase)++import Agda.Syntax.Concrete (TopLevelModuleName)+import Agda.Syntax.Common+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Definitions+  (NiceDeclaration, DeclarationWarning, dwWarning, declarationWarningName)+import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Internal.Generic (TermLike(..))+import Agda.Syntax.Parser (ParseWarning)+import Agda.Syntax.Parser.Monad (parseWarningName)+import Agda.Syntax.Treeless (Compiled)+import Agda.Syntax.Notation+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base+import qualified Agda.Syntax.Info as Info++import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)++-- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend+-- conflicts with Args, defined in Agda.Syntax.Internal and also imported here.+-- This only matters when interpreted in ghci, which sees all of the module's+-- exported symbols, not just the ones defined in the `.hs-boot`. See the+-- comment in ../../Compiler/Backend.hs-boot+import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args)++import Agda.Interaction.Options+import Agda.Interaction.Options.Warnings+import {-# SOURCE #-} Agda.Interaction.Response+  (InteractionOutputCallback, defaultInteractionOutputCallback)+import Agda.Interaction.Highlighting.Precise+  (HighlightingInfo, NameKind)+import Agda.Interaction.Library++import Agda.Utils.Benchmark (MonadBench(..))+import Agda.Utils.BiMap (BiMap, HasTag(..))+import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.FileName+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List2 (List2, pattern List2)+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Pretty+import Agda.Utils.Singleton+import Agda.Utils.SmallSet (SmallSet)+import qualified Agda.Utils.SmallSet as SmallSet+import Agda.Utils.Update+import Agda.Utils.WithDefault ( collapseDefault )++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Type checking state+---------------------------------------------------------------------------++data TCState = TCSt+  { stPreScopeState   :: !PreScopeState+    -- ^ The state which is frozen after scope checking.+  , stPostScopeState  :: !PostScopeState+    -- ^ The state which is modified after scope checking.+  , stPersistentState :: !PersistentTCState+    -- ^ State which is forever, like a diamond.+  }+  deriving Generic++class Monad m => ReadTCState m where+  getTCState :: m TCState+  locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b++  withTCState :: (TCState -> TCState) -> m a -> m a+  withTCState = locallyTCState id++  default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState+  getTCState = lift getTCState++  default locallyTCState+    :: (MonadTransControl t, ReadTCState n, t n ~ m)+    => Lens' a TCState -> (a -> a) -> m b -> m b+  locallyTCState l = liftThrough . locallyTCState l++instance ReadTCState m => ReadTCState (ListT m) where+  locallyTCState l = mapListT . locallyTCState l++instance ReadTCState m => ReadTCState (ChangeT m)+instance ReadTCState m => ReadTCState (ExceptT err m)+instance ReadTCState m => ReadTCState (IdentityT m)+instance ReadTCState m => ReadTCState (MaybeT m)+instance ReadTCState m => ReadTCState (ReaderT r m)+instance ReadTCState m => ReadTCState (StateT s m)+instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m)+++instance Show TCState where+  show _ = "TCSt{}"++data PreScopeState = PreScopeState+  { stPreTokens             :: !HighlightingInfo+    -- ^ Highlighting info for tokens and Happy parser warnings (but+    -- not for those tokens/warnings for which highlighting exists in+    -- 'stPostSyntaxInfo').+  , stPreImports            :: !Signature  -- XX populated by scope checker+    -- ^ Imported declared identifiers.+    --   Those most not be serialized!+  , stPreImportedModules    :: !(Set ModuleName)  -- imports logic+  , stPreModuleToSource     :: !ModuleToSource   -- imports+  , stPreVisitedModules     :: !VisitedModules   -- imports+  , stPreScope              :: !ScopeInfo+    -- generated by scope checker, current file:+    -- which modules you have, public definitions, current file, maps concrete names to abstract names.+  , stPrePatternSyns        :: !A.PatternSynDefns+    -- ^ Pattern synonyms of the current file.  Serialized.+  , stPrePatternSynImports  :: !A.PatternSynDefns+    -- ^ Imported pattern synonyms.  Must not be serialized!+  , stPreGeneralizedVars    :: !(Strict.Maybe (Set QName))+    -- ^ Collected generalizable variables; used during scope checking of terms+  , stPrePragmaOptions      :: !PragmaOptions+    -- ^ Options applying to the current file. @OPTIONS@+    -- pragmas only affect this field.+  , stPreImportedBuiltins   :: !(BuiltinThings PrimFun)+  , stPreImportedDisplayForms :: !DisplayForms+    -- ^ Display forms added by someone else to imported identifiers+  , stPreImportedInstanceDefs :: !InstanceTable+  , stPreForeignCode        :: !(Map BackendName [ForeignCode])+    -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.+    -- Does not include code for imported modules.+  , stPreFreshInteractionId :: !InteractionId+  , stPreImportedUserWarnings :: !(Map A.QName Text)+    -- ^ Imported @UserWarning@s, not to be stored in the @Interface@+  , stPreLocalUserWarnings    :: !(Map A.QName Text)+    -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@+  , stPreWarningOnImport      :: !(Strict.Maybe Text)+    -- ^ Whether the current module should raise a warning when opened+  , stPreImportedPartialDefs :: !(Set QName)+    -- ^ Imported partial definitions, not to be stored in the @Interface@+  , stPreProjectConfigs :: !(Map FilePath ProjectConfig)+    -- ^ Map from directories to paths of closest enclosing .agda-lib+    --   files (or @Nothing@ if there are none).+  , stPreAgdaLibFiles   :: !(Map FilePath AgdaLibFile)+    -- ^ Contents of .agda-lib files that have already been parsed.+  }+  deriving Generic++-- | Name disambiguation for the sake of highlighting.+data DisambiguatedName = DisambiguatedName NameKind A.QName+  deriving Generic+type DisambiguatedNames = IntMap DisambiguatedName++type ConcreteNames = Map Name [C.Name]++data PostScopeState = PostScopeState+  { stPostSyntaxInfo          :: !HighlightingInfo+    -- ^ Highlighting info.+  , stPostDisambiguatedNames  :: !DisambiguatedNames+    -- ^ Disambiguation carried out by the type checker.+    --   Maps position of first name character to disambiguated @'A.QName'@+    --   for each @'A.AmbiguousQName'@ already passed by the type checker.+  , stPostMetaStore           :: !MetaStore+  , stPostInteractionPoints   :: !InteractionPoints -- scope checker first+  , stPostAwakeConstraints    :: !Constraints+  , stPostSleepingConstraints :: !Constraints+  , stPostDirty               :: !Bool -- local+    -- ^ Dirty when a constraint is added, used to prevent pointer update.+    -- Currently unused.+  , stPostOccursCheckDefs     :: !(Set QName) -- local+    -- ^ Definitions to be considered during occurs check.+    --   Initialized to the current mutual block before the check.+    --   During occurs check, we remove definitions from this set+    --   as soon we have checked them.+  , stPostSignature           :: !Signature+    -- ^ Declared identifiers of the current file.+    --   These will be serialized after successful type checking.+  , stPostModuleCheckpoints   :: !(Map ModuleName CheckpointId)+    -- ^ For each module remember the checkpoint corresponding to the orignal+    --   context of the module parameters.+  , stPostImportsDisplayForms :: !DisplayForms+    -- ^ Display forms we add for imported identifiers+  , stPostCurrentModule       :: !(Strict.Maybe ModuleName)+    -- ^ The current module is available after it has been type+    -- checked.+  , stPostInstanceDefs        :: !TempInstanceTable+  , stPostConcreteNames       :: !ConcreteNames+    -- ^ Map keeping track of concrete names assigned to each abstract name+    --   (can be more than one name in case the first one is shadowed)+  , stPostUsedNames           :: !(Map RawName [RawName])+    -- ^ Map keeping track for each name root (= name w/o numeric+    -- suffixes) what names with the same root have been used during a+    -- TC computation. This information is used to build the+    -- @ShadowingNames@ map.+  , stPostShadowingNames      :: !(Map Name [RawName])+    -- ^ Map keeping track for each (abstract) name the list of all+    -- (raw) names that it could maybe be shadowed by.+  , stPostStatistics          :: !Statistics+    -- ^ Counters to collect various statistics about meta variables etc.+    --   Only for current file.+  , stPostTCWarnings          :: ![TCWarning]+  , stPostMutualBlocks        :: !(Map MutualId MutualBlock)+  , stPostLocalBuiltins       :: !(BuiltinThings PrimFun)+  , stPostFreshMetaId         :: !MetaId+  , stPostFreshMutualId       :: !MutualId+  , stPostFreshProblemId      :: !ProblemId+  , stPostFreshCheckpointId   :: !CheckpointId+  , stPostFreshInt            :: !Int+  , stPostFreshNameId         :: !NameId+  , stPostAreWeCaching        :: !Bool+  , stPostPostponeInstanceSearch :: !Bool+  , stPostConsideringInstance :: !Bool+  , stPostInstantiateBlocking :: !Bool+    -- ^ Should we instantiate away blocking metas?+    --   This can produce ill-typed terms but they are often more readable. See issue #3606.+    --   Best set to True only for calls to pretty*/reify to limit unwanted reductions.+  , stPostLocalPartialDefs    :: !(Set QName)+    -- ^ Local partial definitions, to be stored in the @Interface@+  }+  deriving (Generic)++-- | A mutual block of names in the signature.+data MutualBlock = MutualBlock+  { mutualInfo  :: Info.MutualInfo+    -- ^ The original info of the mutual block.+  , mutualNames :: Set QName+  } deriving (Show, Eq, Generic)++instance Null MutualBlock where+  empty = MutualBlock empty empty++-- | A part of the state which is not reverted when an error is thrown+-- or the state is reset.+data PersistentTCState = PersistentTCSt+  { stDecodedModules    :: !DecodedModules+  , stPersistentOptions :: CommandLineOptions+  , stInteractionOutputCallback  :: InteractionOutputCallback+    -- ^ Callback function to call when there is a response+    --   to give to the interactive frontend.+    --   See the documentation of 'InteractionOutputCallback'.+  , stBenchmark         :: !Benchmark+    -- ^ Structure to track how much CPU time was spent on which Agda phase.+    --   Needs to be a strict field to avoid space leaks!+  , stAccumStatistics   :: !Statistics+    -- ^ Should be strict field.+  , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)+    -- ^ Cached typechecking state from the last loaded file.+    --   Should be @Nothing@ when checking imports.+  , stPersistBackends   :: [Backend]+    -- ^ Current backends with their options+  }+  deriving Generic++data LoadedFileCache = LoadedFileCache+  { lfcCached  :: !CachedTypeCheckLog+  , lfcCurrent :: !CurrentTypeCheckLog+  }+  deriving Generic++-- | A log of what the type checker does and states after the action is+-- completed.  The cached version is stored first executed action first.+type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)]++-- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type+-- checking of a module.  Stored in reverse order (last performed action+-- first).+type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)]++-- | A complete log for a module will look like this:+--+--   * 'Pragmas'+--+--   * 'EnterSection', entering the main module.+--+--   * 'Decl'/'EnterSection'/'LeaveSection', for declarations and nested+--     modules+--+--   * 'LeaveSection', leaving the main module.+data TypeCheckAction+  = EnterSection !ModuleName !A.Telescope+  | LeaveSection !ModuleName+  | Decl !A.Declaration+    -- ^ Never a Section or ScopeDecl+  | Pragmas !PragmaOptions+  deriving (Generic)++-- | Empty persistent state.++initPersistentState :: PersistentTCState+initPersistentState = PersistentTCSt+  { stPersistentOptions         = defaultOptions+  , stDecodedModules            = Map.empty+  , stInteractionOutputCallback = defaultInteractionOutputCallback+  , stBenchmark                 = empty+  , stAccumStatistics           = Map.empty+  , stPersistLoadedFileCache    = empty+  , stPersistBackends           = []+  }++-- | Empty state of type checker.++initPreScopeState :: PreScopeState+initPreScopeState = PreScopeState+  { stPreTokens               = mempty+  , stPreImports              = emptySignature+  , stPreImportedModules      = Set.empty+  , stPreModuleToSource       = Map.empty+  , stPreVisitedModules       = Map.empty+  , stPreScope                = emptyScopeInfo+  , stPrePatternSyns          = Map.empty+  , stPrePatternSynImports    = Map.empty+  , stPreGeneralizedVars      = mempty+  , stPrePragmaOptions        = defaultInteractionOptions+  , stPreImportedBuiltins     = Map.empty+  , stPreImportedDisplayForms = HMap.empty+  , stPreImportedInstanceDefs = Map.empty+  , stPreForeignCode          = Map.empty+  , stPreFreshInteractionId   = 0+  , stPreImportedUserWarnings = Map.empty+  , stPreLocalUserWarnings    = Map.empty+  , stPreWarningOnImport      = empty+  , stPreImportedPartialDefs  = Set.empty+  , stPreProjectConfigs       = Map.empty+  , stPreAgdaLibFiles         = Map.empty+  }++initPostScopeState :: PostScopeState+initPostScopeState = PostScopeState+  { stPostSyntaxInfo           = mempty+  , stPostDisambiguatedNames   = IntMap.empty+  , stPostMetaStore            = IntMap.empty+  , stPostInteractionPoints    = empty+  , stPostAwakeConstraints     = []+  , stPostSleepingConstraints  = []+  , stPostDirty                = False+  , stPostOccursCheckDefs      = Set.empty+  , stPostSignature            = emptySignature+  , stPostModuleCheckpoints    = Map.empty+  , stPostImportsDisplayForms  = HMap.empty+  , stPostCurrentModule        = empty+  , stPostInstanceDefs         = (Map.empty , Set.empty)+  , stPostConcreteNames        = Map.empty+  , stPostUsedNames            = Map.empty+  , stPostShadowingNames       = Map.empty+  , stPostStatistics           = Map.empty+  , stPostTCWarnings           = []+  , stPostMutualBlocks         = Map.empty+  , stPostLocalBuiltins        = Map.empty+  , stPostFreshMetaId          = 0+  , stPostFreshMutualId        = 0+  , stPostFreshProblemId       = 1+  , stPostFreshCheckpointId    = 1+  , stPostFreshInt             = 0+  , stPostFreshNameId          = NameId 0 noModuleNameHash+  , stPostAreWeCaching         = False+  , stPostPostponeInstanceSearch = False+  , stPostConsideringInstance  = False+  , stPostInstantiateBlocking  = False+  , stPostLocalPartialDefs     = Set.empty+  }++initState :: TCState+initState = TCSt+  { stPreScopeState   = initPreScopeState+  , stPostScopeState  = initPostScopeState+  , stPersistentState = initPersistentState+  }++-- * st-prefixed lenses+------------------------------------------------------------------------++stTokens :: Lens' HighlightingInfo TCState+stTokens f s =+  f (stPreTokens (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}}++stImports :: Lens' Signature TCState+stImports f s =+  f (stPreImports (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}}++stImportedModules :: Lens' (Set ModuleName) TCState+stImportedModules f s =+  f (stPreImportedModules (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}}++stModuleToSource :: Lens' ModuleToSource TCState+stModuleToSource f s =+  f (stPreModuleToSource (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}}++stVisitedModules :: Lens' VisitedModules TCState+stVisitedModules f s =+  f (stPreVisitedModules (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}}++stScope :: Lens' ScopeInfo TCState+stScope f s =+  f (stPreScope (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}}++stPatternSyns :: Lens' A.PatternSynDefns TCState+stPatternSyns f s =+  f (stPrePatternSyns (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}}++stPatternSynImports :: Lens' A.PatternSynDefns TCState+stPatternSynImports f s =+  f (stPrePatternSynImports (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}}++stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState+stGeneralizedVars f s =+  f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}}++stPragmaOptions :: Lens' PragmaOptions TCState+stPragmaOptions f s =+  f (stPrePragmaOptions (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}}++stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState+stImportedBuiltins f s =+  f (stPreImportedBuiltins (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}}++stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState+stForeignCode f s =+  f (stPreForeignCode (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}}++stFreshInteractionId :: Lens' InteractionId TCState+stFreshInteractionId f s =+  f (stPreFreshInteractionId (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}++stImportedUserWarnings :: Lens' (Map A.QName Text) TCState+stImportedUserWarnings f s =+  f (stPreImportedUserWarnings (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}}++stLocalUserWarnings :: Lens' (Map A.QName Text) TCState+stLocalUserWarnings f s =+  f (stPreLocalUserWarnings (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}}++getUserWarnings :: ReadTCState m => m (Map A.QName Text)+getUserWarnings = do+  iuw <- useR stImportedUserWarnings+  luw <- useR stLocalUserWarnings+  return $ iuw `Map.union` luw++stWarningOnImport :: Lens' (Maybe Text) TCState+stWarningOnImport f s =+  f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}}++stImportedPartialDefs :: Lens' (Set QName) TCState+stImportedPartialDefs f s =+  f (stPreImportedPartialDefs (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}}++stLocalPartialDefs :: Lens' (Set QName) TCState+stLocalPartialDefs f s =+  f (stPostLocalPartialDefs (stPostScopeState s)) <&>+  \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}}++getPartialDefs :: ReadTCState m => m (Set QName)+getPartialDefs = do+  ipd <- useR stImportedPartialDefs+  lpd <- useR stLocalPartialDefs+  return $ ipd `Set.union` lpd++stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState+stLoadedFileCache f s =+  f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&>+  \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}}++stBackends :: Lens' [Backend] TCState+stBackends f s =+  f (stPersistBackends (stPersistentState s)) <&>+  \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}}++stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState+stProjectConfigs f s =+  f (stPreProjectConfigs (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreProjectConfigs = x}}++stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState+stAgdaLibFiles f s =+  f (stPreAgdaLibFiles (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreAgdaLibFiles = x}}++stFreshNameId :: Lens' NameId TCState+stFreshNameId f s =+  f (stPostFreshNameId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}}++stSyntaxInfo :: Lens' HighlightingInfo TCState+stSyntaxInfo f s =+  f (stPostSyntaxInfo (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}}++stDisambiguatedNames :: Lens' DisambiguatedNames TCState+stDisambiguatedNames f s =+  f (stPostDisambiguatedNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}}++stMetaStore :: Lens' MetaStore TCState+stMetaStore f s =+  f (stPostMetaStore (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMetaStore = x}}++stInteractionPoints :: Lens' InteractionPoints TCState+stInteractionPoints f s =+  f (stPostInteractionPoints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}++stAwakeConstraints :: Lens' Constraints TCState+stAwakeConstraints f s =+  f (stPostAwakeConstraints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}}++stSleepingConstraints :: Lens' Constraints TCState+stSleepingConstraints f s =+  f (stPostSleepingConstraints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}}++stDirty :: Lens' Bool TCState+stDirty f s =+  f (stPostDirty (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}}++stOccursCheckDefs :: Lens' (Set QName) TCState+stOccursCheckDefs f s =+  f (stPostOccursCheckDefs (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}}++stSignature :: Lens' Signature TCState+stSignature f s =+  f (stPostSignature (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}}++stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState+stModuleCheckpoints f s =+  f (stPostModuleCheckpoints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}}++stImportsDisplayForms :: Lens' DisplayForms TCState+stImportsDisplayForms f s =+  f (stPostImportsDisplayForms (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}}++stImportedDisplayForms :: Lens' DisplayForms TCState+stImportedDisplayForms f s =+  f (stPreImportedDisplayForms (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}}++stCurrentModule :: Lens' (Maybe ModuleName) TCState+stCurrentModule f s =+  f (Strict.toLazy $ stPostCurrentModule (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = Strict.toStrict x}}++stImportedInstanceDefs :: Lens' InstanceTable TCState+stImportedInstanceDefs f s =+  f (stPreImportedInstanceDefs (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}}++stInstanceDefs :: Lens' TempInstanceTable TCState+stInstanceDefs f s =+  f (stPostInstanceDefs (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}}++stConcreteNames :: Lens' ConcreteNames TCState+stConcreteNames f s =+  f (stPostConcreteNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}}++stUsedNames :: Lens' (Map RawName [RawName]) TCState+stUsedNames f s =+  f (stPostUsedNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}}++stShadowingNames :: Lens' (Map Name [RawName]) TCState+stShadowingNames f s =+  f (stPostShadowingNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}}++stStatistics :: Lens' Statistics TCState+stStatistics f s =+  f (stPostStatistics (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}++stTCWarnings :: Lens' [TCWarning] TCState+stTCWarnings f s =+  f (stPostTCWarnings (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}}++stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState+stMutualBlocks f s =+  f (stPostMutualBlocks (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}++stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState+stLocalBuiltins f s =+  f (stPostLocalBuiltins (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}}++stFreshMetaId :: Lens' MetaId TCState+stFreshMetaId f s =+  f (stPostFreshMetaId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}}++stFreshMutualId :: Lens' MutualId TCState+stFreshMutualId f s =+  f (stPostFreshMutualId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}}++stFreshProblemId :: Lens' ProblemId TCState+stFreshProblemId f s =+  f (stPostFreshProblemId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}++stFreshCheckpointId :: Lens' CheckpointId TCState+stFreshCheckpointId f s =+  f (stPostFreshCheckpointId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}}++stFreshInt :: Lens' Int TCState+stFreshInt f s =+  f (stPostFreshInt (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}}++-- use @areWeCaching@ from the Caching module instead.+stAreWeCaching :: Lens' Bool TCState+stAreWeCaching f s =+  f (stPostAreWeCaching (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}}++stPostponeInstanceSearch :: Lens' Bool TCState+stPostponeInstanceSearch f s =+  f (stPostPostponeInstanceSearch (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}}++stConsideringInstance :: Lens' Bool TCState+stConsideringInstance f s =+  f (stPostConsideringInstance (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}}++stInstantiateBlocking :: Lens' Bool TCState+stInstantiateBlocking f s =+  f (stPostInstantiateBlocking (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}}++stBuiltinThings :: TCState -> BuiltinThings PrimFun+stBuiltinThings s = (s^.stLocalBuiltins) `Map.union` (s^.stImportedBuiltins)+++-- * Fresh things+------------------------------------------------------------------------++class Enum i => HasFresh i where+    freshLens :: Lens' i TCState+    nextFresh' :: i -> i+    nextFresh' = succ++nextFresh :: HasFresh i => TCState -> (i, TCState)+nextFresh s =+  let !c = s^.freshLens+  in (c, set freshLens (nextFresh' c) s)++class Monad m => MonadFresh i m where+  fresh :: m i++  default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i+  fresh = lift fresh++instance MonadFresh i m => MonadFresh i (ReaderT r m)+instance MonadFresh i m => MonadFresh i (StateT s m)+instance MonadFresh i m => MonadFresh i (ListT m)+instance MonadFresh i m => MonadFresh i (IdentityT m)++instance HasFresh i => MonadFresh i TCM where+  fresh = do+        !s <- getTC+        let (!c , !s') = nextFresh s+        putTC s'+        return c++instance HasFresh MetaId where+  freshLens = stFreshMetaId++instance HasFresh MutualId where+  freshLens = stFreshMutualId++instance HasFresh InteractionId where+  freshLens = stFreshInteractionId++instance HasFresh NameId where+  freshLens = stFreshNameId+  -- nextFresh increments the current fresh name by 2 so @NameId@s used+  -- before caching starts do not overlap with the ones used after.+  nextFresh' = succ . succ++instance HasFresh Int where+  freshLens = stFreshInt++instance HasFresh ProblemId where+  freshLens = stFreshProblemId++newtype CheckpointId = CheckpointId Int+  deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData)++instance Show CheckpointId where+  show (CheckpointId n) = show n++instance Pretty CheckpointId where+  pretty (CheckpointId n) = pretty n++instance HasFresh CheckpointId where+  freshLens = stFreshCheckpointId++freshName :: MonadFresh NameId m => Range -> String -> m Name+freshName r s = do+  i <- fresh+  return $ mkName r i s++freshNoName :: MonadFresh NameId m => Range -> m Name+freshNoName r =+    do  i <- fresh+        return $ makeName i (C.NoName noRange i) r noFixity' False++freshNoName_ :: MonadFresh NameId m => m Name+freshNoName_ = freshNoName noRange++freshRecordName :: MonadFresh NameId m => m Name+freshRecordName = do+  i <- fresh+  return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True++-- | Create a fresh name from @a@.+class FreshName a where+  freshName_ :: MonadFresh NameId m => a -> m Name++instance FreshName (Range, String) where+  freshName_ = uncurry freshName++instance FreshName String where+  freshName_ = freshName noRange++instance FreshName Range where+  freshName_ = freshNoName++instance FreshName () where+  freshName_ () = freshNoName_++---------------------------------------------------------------------------+-- ** Managing file names+---------------------------------------------------------------------------++-- | Maps top-level module names to the corresponding source file+-- names.++type ModuleToSource = Map TopLevelModuleName AbsolutePath++-- | Maps source file names to the corresponding top-level module+-- names.++type SourceToModule = Map AbsolutePath TopLevelModuleName++-- | Creates a 'SourceToModule' map based on 'stModuleToSource'.+--+--   O(n log n).+--+--   For a single reverse lookup in 'stModuleToSource',+--   rather use 'lookupModuleFromSourse'.++sourceToModule :: TCM SourceToModule+sourceToModule =+  Map.fromList+     .  List.map (\(m, f) -> (f, m))+     .  Map.toList+    <$> useTC stModuleToSource++-- | Lookup an 'AbsolutePath' in 'sourceToModule'.+--+--   O(n).++lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName)+lookupModuleFromSource f =+  fmap fst . List.find ((f ==) . snd) . Map.toList <$> useR stModuleToSource+++---------------------------------------------------------------------------+-- ** Associating concrete names to an abstract name+---------------------------------------------------------------------------++-- | A monad that has read and write access to the stConcreteNames+--   part of the TCState. Basically, this is a synonym for `MonadState+--   ConcreteNames m` (which cannot be used directly because of the+--   limitations of Haskell's typeclass system).+class Monad m => MonadStConcreteNames m where+  runStConcreteNames :: StateT ConcreteNames m a -> m a++  useConcreteNames :: m ConcreteNames+  useConcreteNames = runStConcreteNames get++  modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m ()+  modifyConcreteNames = runStConcreteNames . modify++instance MonadStConcreteNames TCM where+  runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m++instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where+  runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m++instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where+  runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m)++instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where+  runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do+    ((x,ns'),s') <- runStateT (runStateT m ns) s+    return ((x,s'),ns')++---------------------------------------------------------------------------+-- ** Interface+---------------------------------------------------------------------------+++-- | Distinguishes between type-checked and scope-checked interfaces+--   when stored in the map of `VisitedModules`.+data ModuleCheckMode+  = ModuleScopeChecked+  | ModuleTypeChecked+  deriving (Eq, Ord, Bounded, Enum, Show, Generic)+++data ModuleInfo = ModuleInfo+  { miInterface  :: Interface+  , miWarnings   :: [TCWarning]+    -- ^ Warnings were encountered when the module was type checked.+    --   These might include warnings not stored in the interface itself,+    --   specifically unsolved interaction metas.+    --   See "Agda.Interaction.Imports"+  , miPrimitive  :: Bool+    -- ^ 'True' if the module is a primitive module, which should always+    -- be importable.+  , miMode       :: ModuleCheckMode+    -- ^ The `ModuleCheckMode` used to create the `Interface`+  }+  deriving Generic++-- Note that the use of 'C.TopLevelModuleName' here is a potential+-- performance problem, because these names do not contain unique+-- identifiers.++type VisitedModules = Map C.TopLevelModuleName ModuleInfo+type DecodedModules = Map C.TopLevelModuleName ModuleInfo++data ForeignCode = ForeignCode Range String+  deriving (Show, Generic)++data Interface = Interface+  { iSourceHash      :: Hash+    -- ^ Hash of the source code.+  , iSource          :: TL.Text+    -- ^ The source code. The source code is stored so that the HTML+    -- and LaTeX backends can generate their output without having to+    -- re-read the (possibly out of date) source code.+  , iFileType        :: FileType+    -- ^ Source file type, determined from the file extension+  , iImportedModules :: [(ModuleName, Hash)]+    -- ^ Imported modules and their hashes.+  , iModuleName      :: ModuleName+    -- ^ Module name of this interface.+  , iScope           :: Map ModuleName Scope+    -- ^ Scope defined by this module.+    --+    --   Andreas, AIM XX: Too avoid duplicate serialization, this field is+    --   not serialized, so if you deserialize an interface, @iScope@+    --   will be empty.+    --   But 'constructIScope' constructs 'iScope' from 'iInsideScope'.+  , iInsideScope     :: ScopeInfo+    -- ^ Scope after we loaded this interface.+    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'+    --   and     'Agda.Interaction.CommandLine.interactionLoop'.+  , iSignature       :: Signature+  , iDisplayForms    :: DisplayForms+    -- ^ Display forms added for imported identifiers.+  , iUserWarnings    :: Map A.QName Text+    -- ^ User warnings for imported identifiers+  , iImportWarning   :: Maybe Text+    -- ^ Whether this module should raise a warning when imported+  , iBuiltin         :: BuiltinThings (String, QName)+  , iForeignCode     :: Map BackendName [ForeignCode]+  , iHighlighting    :: HighlightingInfo+  , iDefaultPragmaOptions :: [OptionsPragma]+    -- ^ Pragma options set in library files.+  , iFilePragmaOptions    :: [OptionsPragma]+    -- ^ Pragma options set in the file.+  , iOptionsUsed     :: PragmaOptions+    -- ^ Options/features used when checking the file (can be different+    --   from options set directly in the file).+  , iPatternSyns     :: A.PatternSynDefns+  , iWarnings        :: [TCWarning]+  , iPartialDefs     :: Set QName+  }+  deriving (Show, Generic)++instance Pretty Interface where+  pretty (Interface+            sourceH source fileT importedM moduleN scope insideS signature+            display userwarn importwarn builtin foreignCode highlighting+            libPragmaO filePragmaO+            oUsed patternS warnings partialdefs) =++    hang "Interface" 2 $ vcat+      [ "source hash:"         <+> (pretty . show) sourceH+      , "source:"              $$  nest 2 (text $ TL.unpack source)+      , "file type:"           <+> (pretty . show) fileT+      , "imported modules:"    <+> (pretty . show) importedM+      , "module name:"         <+> pretty moduleN+      , "scope:"               <+> (pretty . show) scope+      , "inside scope:"        <+> (pretty . show) insideS+      , "signature:"           <+> (pretty . show) signature+      , "display:"             <+> (pretty . show) display+      , "user warnings:"       <+> (pretty . show) userwarn+      , "import warning:"      <+> (pretty . show) importwarn+      , "builtin:"             <+> (pretty . show) builtin+      , "Foreign code:"        <+> (pretty . show) foreignCode+      , "highlighting:"        <+> (pretty . show) highlighting+      , "library pragma options:" <+> (pretty . show) libPragmaO+      , "file pragma options:" <+> (pretty . show) filePragmaO+      , "options used:"        <+> (pretty . show) oUsed+      , "pattern syns:"        <+> (pretty . show) patternS+      , "warnings:"            <+> (pretty . show) warnings+      , "partial definitions:" <+> (pretty . show) partialdefs+      ]++-- | Combines the source hash and the (full) hashes of the imported modules.+iFullHash :: Interface -> Hash+iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)++---------------------------------------------------------------------------+-- ** Closure+---------------------------------------------------------------------------++data Closure a = Closure+  { clSignature        :: Signature+  , clEnv              :: TCEnv+  , clScope            :: ScopeInfo+  , clModuleCheckpoints :: Map ModuleName CheckpointId+  , clValue            :: a+  }+    deriving (Functor, Foldable, Generic)++instance Show a => Show (Closure a) where+  show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }"++instance HasRange a => HasRange (Closure a) where+  getRange = getRange . clValue++class LensClosure a b | b -> a where+  lensClosure :: Lens' (Closure a) b++instance LensClosure a (Closure a) where+  lensClosure = id++instance LensTCEnv (Closure a) where+  lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }++buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a)+buildClosure x = do+    env   <- askTC+    sig   <- useR stSignature+    scope <- useR stScope+    cps   <- useR stModuleCheckpoints+    return $ Closure sig env scope cps x++---------------------------------------------------------------------------+-- ** Constraints+---------------------------------------------------------------------------++type Constraints = [ProblemConstraint]++data ProblemConstraint = PConstr+  { constraintProblems  :: Set ProblemId+  , constraintUnblocker :: Blocker+  , theConstraint       :: Closure Constraint+  }+  deriving (Show, Generic)++instance HasRange ProblemConstraint where+  getRange = getRange . theConstraint++data Constraint+  = ValueCmp Comparison CompareAs Term Term+  | ValueCmpOnFace Comparison Term Type Term Term+  | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim]+  | SortCmp Comparison Sort Sort+  | LevelCmp Comparison Level Level+--  | ShortCut MetaId Term Type+--    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.+  | HasBiggerSort Sort+  | HasPTSRule (Dom Type) (Abs Sort)+  | CheckMetaInst MetaId+  | UnBlock MetaId+    -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved+    --   constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst'+    --   or 'PostponedTypeCheckingProblem'.+  | IsEmpty Range Type+    -- ^ The range is the one of the absurd pattern.+  | CheckSizeLtSat Term+    -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT.+  | FindInstance MetaId (Maybe [Candidate])+    -- ^ the first argument is the instance argument and the second one is the list of candidates+    --   (or Nothing if we haven’t determined the list of candidates yet)+  | CheckFunDef Delayed A.DefInfo QName [A.Clause] TCErr+    -- ^ Last argument is the error causing us to postpone.+  | UnquoteTactic Term Term Type   -- ^ First argument is computation and the others are hole and goal type+  | CheckLockedVars Term Type (Arg Term) Type     -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed.+  | UsableAtModality Modality Term   -- ^ is the term usable at the given modality?+  deriving (Show, Generic)++instance HasRange Constraint where+  getRange (IsEmpty r t) = r+  getRange _ = noRange+{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId+  getRange (ValueCmp cmp a u v) = getRange (a,u,v)+  getRange (ElimCmp pol a v es es') = getRange (a,v,es,es')+  getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel')+  getRange (SortCmp cmp s s') = getRange (s,s')+  getRange (LevelCmp cmp l l') = getRange (l,l')+  getRange (UnBlock x) = getRange x+  getRange (FindInstance x cands) = getRange x+-}++instance Free Constraint where+  freeVars' c =+    case c of+      ValueCmp _ t u v      -> freeVars' (t, (u, v))+      ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v)))+      ElimCmp _ _ t u es es'  -> freeVars' ((t, u), (es, es'))+      SortCmp _ s s'        -> freeVars' (s, s')+      LevelCmp _ l l'       -> freeVars' (l, l')+      UnBlock _             -> mempty+      IsEmpty _ t           -> freeVars' t+      CheckSizeLtSat u      -> freeVars' u+      FindInstance _ cs     -> freeVars' cs+      CheckFunDef{}         -> mempty+      HasBiggerSort s       -> freeVars' s+      HasPTSRule a s        -> freeVars' (a , s)+      CheckLockedVars a b c d -> freeVars' ((a,b),(c,d))+      UnquoteTactic t h g   -> freeVars' (t, (h, g))+      CheckMetaInst m       -> mempty+      UsableAtModality mod t -> freeVars' t++instance TermLike Constraint where+  foldTerm f = \case+      ValueCmp _ t u v       -> foldTerm f (t, u, v)+      ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v)+      ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es')+      LevelCmp _ l l'        -> foldTerm f (Level l, Level l')  -- Note wrapping as term, to ensure f gets to act on l and l'+      IsEmpty _ t            -> foldTerm f t+      CheckSizeLtSat u       -> foldTerm f u+      UnquoteTactic t h g    -> foldTerm f (t, h, g)+      SortCmp _ s1 s2        -> foldTerm f (Sort s1, Sort s2)   -- Same as LevelCmp case+      UnBlock _              -> mempty+      CheckLockedVars a b c d -> foldTerm f (a, b, c, d)+      FindInstance _ _       -> mempty+      CheckFunDef{}          -> mempty+      HasBiggerSort s        -> foldTerm f s+      HasPTSRule a s         -> foldTerm f (a, Sort <$> s)+      CheckMetaInst m        -> mempty+      UsableAtModality m t   -> foldTerm f t++  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented++instance AllMetas Constraint++data Comparison = CmpEq | CmpLeq+  deriving (Eq, Data, Show, Generic)++instance Pretty Comparison where+  pretty CmpEq  = "="+  pretty CmpLeq = "=<"++-- | An extension of 'Comparison' to @>=@.+data CompareDirection = DirEq | DirLeq | DirGeq+  deriving (Eq, Show)++instance Pretty CompareDirection where+  pretty = text . \case+    DirEq  -> "="+    DirLeq -> "=<"+    DirGeq -> ">="++-- | Embed 'Comparison' into 'CompareDirection'.+fromCmp :: Comparison -> CompareDirection+fromCmp CmpEq  = DirEq+fromCmp CmpLeq = DirLeq++-- | Flip the direction of comparison.+flipCmp :: CompareDirection -> CompareDirection+flipCmp DirEq  = DirEq+flipCmp DirLeq = DirGeq+flipCmp DirGeq = DirLeq++-- | Turn a 'Comparison' function into a 'CompareDirection' function.+--+--   Property: @dirToCmp f (fromCmp cmp) = f cmp@+dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c+dirToCmp cont DirEq  = cont CmpEq+dirToCmp cont DirLeq = cont CmpLeq+dirToCmp cont DirGeq = flip $ cont CmpLeq++-- | We can either compare two terms at a given type, or compare two+--   types without knowing (or caring about) their sorts.+data CompareAs+  = AsTermsOf Type -- ^ @Type@ should not be @Size@.+                   --   But currently, we do not rely on this invariant.+  | AsSizes        -- ^ Replaces @AsTermsOf Size@.+  | AsTypes+  deriving (Data, Show, Generic)++instance Free CompareAs where+  freeVars' (AsTermsOf a) = freeVars' a+  freeVars' AsSizes       = mempty+  freeVars' AsTypes       = mempty++instance TermLike CompareAs where+  foldTerm f (AsTermsOf a) = foldTerm f a+  foldTerm f AsSizes       = mempty+  foldTerm f AsTypes       = mempty++  traverseTermM f = \case+    AsTermsOf a -> AsTermsOf <$> traverseTermM f a+    AsSizes     -> return AsSizes+    AsTypes     -> return AsTypes++instance AllMetas CompareAs++---------------------------------------------------------------------------+-- * Open things+---------------------------------------------------------------------------++-- | A thing tagged with the context it came from. Also keeps the substitution from previous+--   checkpoints. This lets us handle the case when an open thing was created in a context that we+--   have since exited. Remember which module it's from to make sure we don't get confused by+--   checkpoints from other files.+data Open a = OpenThing { openThingCheckpoint    :: CheckpointId+                        , openThingCheckpointMap :: Map CheckpointId Substitution+                        , openThingModule        :: ModuleNameHash+                        , openThing              :: a }+    deriving (Show, Functor, Foldable, Traversable, Generic)++instance Decoration Open where+  traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x++instance Pretty a => Pretty (Open a) where+  prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $+    "OpenThing" <+> pretty cp <+> pretty (Map.toList env) <?> prettyPrec 10 x++---------------------------------------------------------------------------+-- * Judgements+--+-- Used exclusively for typing of meta variables.+---------------------------------------------------------------------------++-- | Parametrized since it is used without MetaId when creating a new meta.+data Judgement a+  = HasType+    { jMetaId     :: a+    , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type?+    , jMetaType   :: Type+    }+  | IsSort+    { jMetaId   :: a+    , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas+    }+  deriving Generic++instance Pretty a => Pretty (Judgement a) where+    pretty (HasType a cmp t) = hsep [ pretty a, ":"    , pretty t ]+    pretty (IsSort  a t)     = hsep [ pretty a, ":sort", pretty t ]++-----------------------------------------------------------------------------+-- ** Generalizable variables+-----------------------------------------------------------------------------++data DoGeneralize+  = YesGeneralizeVar  -- ^ Generalize because it is a generalizable variable.+  | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and+                      --   we're currently checking the type of a generalizable variable+                      --   (this should get the default modality).+  | NoGeneralize      -- ^ Don't generalize.+  deriving (Eq, Ord, Show, Data, Generic)++-- | The value of a generalizable variable. This is created to be a+--   generalizable meta before checking the type to be generalized.+data GeneralizedValue = GeneralizedValue+  { genvalCheckpoint :: CheckpointId+  , genvalTerm       :: Term+  , genvalType       :: Type+  } deriving (Show, Data, Generic)++---------------------------------------------------------------------------+-- ** Meta variables+---------------------------------------------------------------------------++data MetaVariable =+        MetaVar { mvInfo          :: MetaInfo+                , mvPriority      :: MetaPriority -- ^ some metavariables are more eager to be instantiated+                , mvPermutation   :: Permutation+                  -- ^ a metavariable doesn't have to depend on all variables+                  --   in the context, this "permutation" will throw away the+                  --   ones it does not depend on+                , mvJudgement     :: Judgement MetaId+                , mvInstantiation :: MetaInstantiation+                , mvListeners     :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one+                , mvFrozen        :: Frozen -- ^ are we past the point where we can instantiate this meta variable?+                , mvTwin          :: Maybe MetaId -- ^ @Just m@ means this meta will be equated to @m@ when the latter is unblocked. See @blockedTermOnProblem@.+                }+  deriving Generic++data Listener = EtaExpand MetaId+              | CheckConstraint Nat ProblemConstraint+  deriving Generic++instance Eq Listener where+  EtaExpand       x   == EtaExpand       y   = x == y+  CheckConstraint x _ == CheckConstraint y _ = x == y+  _ == _ = False++instance Ord Listener where+  EtaExpand       x   `compare` EtaExpand       y   = x `compare` y+  CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y+  EtaExpand{} `compare` CheckConstraint{} = LT+  CheckConstraint{} `compare` EtaExpand{} = GT++-- | Frozen meta variable cannot be instantiated by unification.+--   This serves to prevent the completion of a definition by its use+--   outside of the current block.+--   (See issues 118, 288, 399).+data Frozen+  = Frozen        -- ^ Do not instantiate.+  | Instantiable+    deriving (Eq, Show, Generic)++data MetaInstantiation+        = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)+        | Open               -- ^ unsolved+        | OpenInstance       -- ^ open, to be instantiated by instance search+        | BlockedConst Term  -- ^ solution blocked by unsolved constraints+        | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)+  deriving Generic++-- | Solving a 'CheckArgs' constraint may or may not check the target type. If+--   it did, it returns a handle to any unsolved constraints.+data CheckedTarget = CheckedTarget (Maybe ProblemId)+                   | NotCheckedTarget++data PrincipalArgTypeMetas = PrincipalArgTypeMetas+  { patmMetas     :: Args -- ^ metas created for hidden and instance arguments+                          --   in the principal argument's type+  , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and+                          --   instance arguments+  }+  deriving Generic++data TypeCheckingProblem+  = CheckExpr Comparison A.Expr Type+  | CheckArgs Comparison ExpandHidden Range [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)+  | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Args Type Int Term Type PrincipalArgTypeMetas+  | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type+    -- ^ @(λ (xs : t₀) → e) : t@+    --   This is not an instance of 'CheckExpr' as the domain type+    --   has already been checked.+    --   For example, when checking+    --     @(λ (x y : Fin _) → e) : (x : Fin n) → ?@+    --   we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@+    --   is a 'Type' rather than an 'A.Expr'.+  | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`+  deriving Generic++instance Show MetaInstantiation where+  show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"+  show Open      = "Open"+  show OpenInstance = "OpenInstance"+  show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")"+  show (PostponedTypeCheckingProblem{}) = "PostponedTypeCheckingProblem (...)"++-- | Meta variable priority:+--   When we have an equation between meta-variables, which one+--   should be instantiated?+--+--   Higher value means higher priority to be instantiated.+newtype MetaPriority = MetaPriority Int+    deriving (Eq, Ord, Show, NFData)++data RunMetaOccursCheck+  = RunMetaOccursCheck+  | DontRunMetaOccursCheck+  deriving (Eq, Ord, Show, Generic)++-- | @MetaInfo@ is cloned from one meta to the next during pruning.+data MetaInfo = MetaInfo+  { miClosRange       :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range.+  , miModality        :: Modality           -- ^ Instantiable with irrelevant/erased solution?+  , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions?+  , miNameSuggestion  :: MetaNameSuggestion+    -- ^ Used for printing.+    --   @Just x@ if meta-variable comes from omitted argument with name @x@.+  , miGeneralizable   :: Arg DoGeneralize+    -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo?+  }+  deriving Generic++instance LensModality MetaInfo where+  getModality = miModality+  setModality mod mi = mi { miModality = mod }+  mapModality f mi = mi { miModality = f $ miModality mi }++instance LensQuantity MetaInfo where+  getQuantity   = getQuantity . getModality+  mapQuantity f = mapModality (mapQuantity f)++-- | Name suggestion for meta variable.  Empty string means no suggestion.+type MetaNameSuggestion = String++-- | For printing, we couple a meta with its name suggestion.+data NamedMeta = NamedMeta+  { nmSuggestion :: MetaNameSuggestion+  , nmid         :: MetaId+  }++instance Pretty NamedMeta where+  pretty (NamedMeta "" x) = pretty x+  pretty (NamedMeta "_" x) = pretty x+  pretty (NamedMeta s  x) = text $ "_" ++ s ++ prettyShow x++type MetaStore = IntMap MetaVariable++instance HasRange MetaInfo where+  getRange = clValue . miClosRange++instance HasRange MetaVariable where+    getRange m = getRange $ getMetaInfo m++instance SetRange MetaInfo where+  setRange r m = m { miClosRange = (miClosRange m) { clValue = r }}++instance SetRange MetaVariable where+  setRange r m = m { mvInfo = setRange r (mvInfo m) }++instance LensModality MetaVariable where+  getModality = getModality . mvInfo+  setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv }+  mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv }++instance LensQuantity MetaVariable where+  getQuantity   = getQuantity . getModality+  mapQuantity f = mapModality (mapQuantity f)++normalMetaPriority :: MetaPriority+normalMetaPriority = MetaPriority 0++lowMetaPriority :: MetaPriority+lowMetaPriority = MetaPriority (-10)++highMetaPriority :: MetaPriority+highMetaPriority = MetaPriority 10++getMetaInfo :: MetaVariable -> Closure Range+getMetaInfo = miClosRange . mvInfo++getMetaScope :: MetaVariable -> ScopeInfo+getMetaScope m = clScope $ getMetaInfo m++getMetaEnv :: MetaVariable -> TCEnv+getMetaEnv m = clEnv $ getMetaInfo m++getMetaSig :: MetaVariable -> Signature+getMetaSig m = clSignature $ getMetaInfo m++getMetaRelevance :: MetaVariable -> Relevance+getMetaRelevance = getRelevance . getModality++getMetaModality :: MetaVariable -> Modality+getMetaModality = getModality++-- Lenses++metaFrozen :: Lens' Frozen MetaVariable+metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }++_mvInfo :: Lens' MetaInfo MetaVariable+_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }++-- Lenses onto Closure Range++instance LensClosure Range MetaInfo where+  lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }++instance LensClosure Range MetaVariable where+  lensClosure = _mvInfo . lensClosure++-- Lenses onto IsAbstract++instance LensIsAbstract TCEnv where+  lensIsAbstract f env =+     -- Andreas, 2019-08-19+     -- Using $! to prevent space leaks like #1829.+     -- This can crash when trying to get IsAbstract from IgnoreAbstractMode.+    (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env))+    <&> \ a -> env { envAbstractMode = aDefToMode a }++instance LensIsAbstract (Closure a) where+  lensIsAbstract = lensTCEnv . lensIsAbstract++instance LensIsAbstract MetaInfo where+  lensIsAbstract = lensClosure . lensIsAbstract++---------------------------------------------------------------------------+-- ** Interaction meta variables+---------------------------------------------------------------------------++-- | Interaction points are created by the scope checker who sets the range.+--   The meta variable is created by the type checker and then hooked up to the+--   interaction point.+data InteractionPoint = InteractionPoint+  { ipRange :: Range        -- ^ The position of the interaction point.+  , ipMeta  :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.+  , ipSolved:: Bool         -- ^ Has this interaction point already been solved?+  , ipClause:: IPClause+      -- ^ The clause of the interaction point (if any).+      --   Used for case splitting.+  }+  deriving Generic++instance Eq InteractionPoint where (==) = (==) `on` ipMeta++instance HasTag InteractionPoint where+  type Tag InteractionPoint = MetaId+  tag = ipMeta++-- | Data structure managing the interaction points.+--+--   We never remove interaction points from this map, only set their+--   'ipSolved' to @True@.  (Issue #2368)+type InteractionPoints = BiMap InteractionId InteractionPoint++-- | Flag to indicate whether the meta is overapplied in the+--   constraint.  A meta is overapplied if it has more arguments than+--   the size of the telescope in its creation environment+--   (as stored in MetaInfo).+data Overapplied = Overapplied | NotOverapplied+  deriving (Eq, Show, Data, Generic)++-- | Datatype representing a single boundary condition:+--   x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es+data IPBoundary' t = IPBoundary+  { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n]+  , ipbValue     :: t          -- ^ @t@+  , ipbMetaApp   :: t          -- ^ @?n es@+  , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ?+  }+  deriving (Show, Data, Functor, Foldable, Traversable, Generic)++type IPBoundary = IPBoundary' Term++-- | Which clause is an interaction point located in?+data IPClause = IPClause+  { ipcQName    :: QName              -- ^ The name of the function.+  , ipcClauseNo :: Int                -- ^ The number of the clause of this function.+  , ipcType     :: Type               -- ^ The type of the function+  , ipcWithSub  :: Maybe Substitution -- ^ Module parameter substitution+  , ipcClause   :: A.SpineClause      -- ^ The original AST clause.+  , ipcClosure  :: Closure ()         -- ^ Environment for rechecking the clause.+  , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS.+  }+  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.+  deriving (Generic)++instance Eq IPClause where+  IPNoClause           == IPNoClause             = True+  IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i'+  _                    == _                      = False++---------------------------------------------------------------------------+-- ** Signature+---------------------------------------------------------------------------++data Signature = Sig+      { _sigSections    :: Sections+      , _sigDefinitions :: Definitions+      , _sigRewriteRules:: RewriteRuleMap  -- ^ The rewrite rules defined in this file.+      }+  deriving (Show, Generic)++sigSections :: Lens' Sections Signature+sigSections f s =+  f (_sigSections s) <&>+  \x -> s {_sigSections = x}++sigDefinitions :: Lens' Definitions Signature+sigDefinitions f s =+  f (_sigDefinitions s) <&>+  \x -> s {_sigDefinitions = x}++sigRewriteRules :: Lens' RewriteRuleMap Signature+sigRewriteRules f s =+  f (_sigRewriteRules s) <&>+  \x -> s {_sigRewriteRules = x}++type Sections    = Map ModuleName Section+type Definitions = HashMap QName Definition+type RewriteRuleMap = HashMap QName RewriteRules+type DisplayForms = HashMap QName [LocalDisplayForm]++newtype Section = Section { _secTelescope :: Telescope }+  deriving (Data, Show, NFData)++instance Pretty Section where+  pretty = pretty . _secTelescope++secTelescope :: Lens' Telescope Section+secTelescope f s =+  f (_secTelescope s) <&>+  \x -> s {_secTelescope = x}++emptySignature :: Signature+emptySignature = Sig Map.empty HMap.empty HMap.empty++-- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a+--   constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a+--   more readable 'Abstract.Syntax'.+--+--   The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables+--   that matches any term.+data DisplayForm = Display+  { dfPatternVars :: Nat+    -- ^ Number @n@ of pattern variables in 'dfPats'.+  , dfPats :: Elims+    -- ^ Left hand side patterns, the @n@ first free variables are pattern variables,+    --   any variables above @n@ are fixed and only match that particular variable. This+    --   happens when you have display forms inside parameterised modules that match on the module+    --   parameters. The 'ArgInfo' is ignored in these patterns.+  , dfRHS :: DisplayTerm+    -- ^ Right hand side.+  }+  deriving (Data, Show, Generic)++type LocalDisplayForm = Open DisplayForm++-- | A structured presentation of a 'Term' for reification into+--   'Abstract.Syntax'.+data DisplayTerm+  = DWithApp DisplayTerm [DisplayTerm] Elims+    -- ^ @(f vs | ws) es@.+    --   The first 'DisplayTerm' is the parent function @f@ with its args @vs@.+    --   The list of 'DisplayTerm's are the with expressions @ws@.+    --   The 'Elims' are additional arguments @es@+    --   (possible in case the with-application is of function type)+    --   or projections (if it is of record type).+  | DCon ConHead ConInfo [Arg DisplayTerm]+    -- ^ @c vs@.+  | DDef QName [Elim' DisplayTerm]+    -- ^ @d vs@.+  | DDot Term+    -- ^ @.v@.+  | DTerm Term+    -- ^ @v@.+  deriving (Data, Show, Generic)++instance Free DisplayForm where+  freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t)++instance Free DisplayTerm where+  freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))+  freeVars' (DCon _ _ vs)      = freeVars' vs+  freeVars' (DDef _ es)        = freeVars' es+  freeVars' (DDot v)           = freeVars' v+  freeVars' (DTerm v)          = freeVars' v++instance Pretty DisplayTerm where+  prettyPrec p v =+    case v of+      DTerm v          -> prettyPrec p v+      DDot v           -> "." <> prettyPrec 10 v+      DDef f es        -> pretty f `pApp` es+      DCon c _ vs      -> pretty (conName c) `pApp` map Apply vs+      DWithApp h ws es ->+        mparens (p > 0)+          (sep [ pretty h+              , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ])+        `pApp` es+    where+      pApp :: Pretty el => Doc -> [el] -> Doc+      pApp d els = mparens (not (null els) && p > 9) $+                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]++instance Pretty DisplayForm where+  prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $+    "Display" <?> fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ]++-- | By default, we have no display form.+defaultDisplayForm :: QName -> [LocalDisplayForm]+defaultDisplayForm c = []++-- | Non-linear (non-constructor) first-order pattern.+data NLPat+  = PVar !Int [Arg Int]+    -- ^ Matches anything (modulo non-linearity) that only contains bound+    --   variables that occur in the given arguments.+  | PDef QName PElims+    -- ^ Matches @f es@+  | PLam ArgInfo (Abs NLPat)+    -- ^ Matches @λ x → t@+  | PPi (Dom NLPType) (Abs NLPType)+    -- ^ Matches @(x : A) → B@+  | PSort NLPSort+    -- ^ Matches a sort of the given shape.+  | PBoundVar {-# UNPACK #-} !Int PElims+    -- ^ Matches @x es@ where x is a lambda-bound variable+  | PTerm Term+    -- ^ Matches the term modulo β (ideally βη).+  deriving (Data, Show, Generic)+type PElims = [Elim' NLPat]++data NLPType = NLPType+  { nlpTypeSort :: NLPSort+  , nlpTypeUnEl :: NLPat+  } deriving (Data, Show, Generic)++data NLPSort+  = PType NLPat+  | PProp NLPat+  | PInf IsFibrant Integer+  | PSizeUniv+  | PLockUniv+  deriving (Data, Show, Generic)++type RewriteRules = [RewriteRule]++-- | Rewrite rules can be added independently from function clauses.+data RewriteRule = RewriteRule+  { rewName    :: QName      -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@+                             --   where @≡@ is the rewrite relation.+  , rewContext :: Telescope  -- ^ @Γ@.+  , rewHead    :: QName      -- ^ @f@.+  , rewPats    :: PElims     -- ^ @Γ ⊢ f ps : t@.+  , rewRHS     :: Term       -- ^ @Γ ⊢ rhs : t@.+  , rewType    :: Type       -- ^ @Γ ⊢ t@.+  , rewFromClause :: Bool    -- ^ Was this rewrite rule created from a clause in the definition of the function?+  }+    deriving (Data, Show, Generic)++data Definition = Defn+  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.+  , defName           :: QName   -- ^ The canonical name, used e.g. in compilation.+  , defType           :: Type    -- ^ Type of the lifted definition.+  , defPolarity       :: [Polarity]+    -- ^ Variance information on arguments of the definition.+    --   Does not include info for dropped parameters to+    --   projection(-like) functions and constructors.+  , defArgOccurrences :: [Occurrence]+    -- ^ Positivity information on arguments of the definition.+    --   Does not include info for dropped parameters to+    --   projection(-like) functions and constructors.++    --   Sometimes Agda looks up 'Occurrence's in these lists based on+    --   their position, so one might consider replacing the list+    --   with, say, an 'IntMap'. However, presumably these lists tend+    --   to be short, in which case 'IntMap's could be slower than+    --   lists. For instance, at one point the longest list+    --   encountered for the standard library (in serialised+    --   interfaces) had length 27. Distribution:+    --+    --   Length, number of lists+    --   -----------------------+    --+    --    0, 2444+    --    1,  721+    --    2,  433+    --    3,  668+    --    4,  602+    --    5,  624+    --    6,  626+    --    7,  484+    --    8,  375+    --    9,  264+    --   10,  305+    --   11,  188+    --   12,  171+    --   13,  108+    --   14,   84+    --   15,   80+    --   16,   38+    --   17,   23+    --   18,   16+    --   19,    8+    --   20,    7+    --   21,    5+    --   22,    2+    --   23,    3+    --   27,    1++  , defArgGeneralizable :: NumGeneralizableArgs+    -- ^ How many arguments should be generalised.+  , defGeneralizedParams :: [Maybe Name]+    -- ^ Gives the name of the (bound variable) parameter for named generalized+    --   parameters. This is needed to bring it into scope when type checking+    --   the data/record definition corresponding to a type with generalized+    --   parameters.+  , defDisplay        :: [LocalDisplayForm]+  , defMutual         :: MutualId+  , defCompiledRep    :: CompiledRepresentation+  , defInstance       :: Maybe QName+    -- ^ @Just q@ when this definition is an instance of class q+  , defCopy           :: Bool+    -- ^ Has this function been created by a module+                         -- instantiation?+  , defMatchable      :: Set QName+    -- ^ The set of symbols with rewrite rules that match against this symbol+  , defNoCompilation  :: Bool+    -- ^ should compilers skip this? Used for e.g. cubical's comp+  , defInjective      :: Bool+    -- ^ Should the def be treated as injective by the pattern matching unifier?+  , defCopatternLHS   :: Bool+    -- ^ Is this a function defined by copatterns?+  , defBlocked        :: Blocked_+    -- ^ What blocking tag to use when we cannot reduce this def?+    --   Used when checking a function definition is blocked on a meta+    --   in the type.+  , theDef            :: Defn+  }+    deriving (Show, Generic)++instance LensArgInfo Definition where+  getArgInfo = defArgInfo+  mapArgInfo f def = def { defArgInfo = f $ defArgInfo def }++instance LensModality  Definition where+instance LensQuantity  Definition where+instance LensRelevance Definition where++data NumGeneralizableArgs+  = NoGeneralizableArgs+  | SomeGeneralizableArgs !Int+    -- ^ When lambda-lifting new args are generalizable if+    --   'SomeGeneralizableArgs', also when the number is zero.+  deriving (Data, Show)++theDefLens :: Lens' Defn Definition+theDefLens f d = f (theDef d) <&> \ df -> d { theDef = df }++-- | Create a definition with sensible defaults.+defaultDefn :: ArgInfo -> QName -> Type -> Defn -> Definition+defaultDefn info x t def = Defn+  { defArgInfo        = info+  , defName           = x+  , defType           = t+  , defPolarity       = []+  , defArgOccurrences = []+  , defArgGeneralizable = NoGeneralizableArgs+  , defGeneralizedParams = []+  , defDisplay        = defaultDisplayForm x+  , defMutual         = 0+  , defCompiledRep    = noCompiledRep+  , defInstance       = Nothing+  , defCopy           = False+  , defMatchable      = Set.empty+  , defNoCompilation  = False+  , defInjective      = False+  , defCopatternLHS   = False+  , defBlocked        = NotBlocked ReallyNotBlocked ()+  , theDef            = def+  }++-- | Polarity for equality and subtype checking.+data Polarity+  = Covariant      -- ^ monotone+  | Contravariant  -- ^ antitone+  | Invariant      -- ^ no information (mixed variance)+  | Nonvariant     -- ^ constant+  deriving (Data, Show, Eq, Generic)++instance Pretty Polarity where+  pretty = text . \case+    Covariant     -> "+"+    Contravariant -> "-"+    Invariant     -> "*"+    Nonvariant    -> "_"++-- | Information about whether an argument is forced by the type of a function.+data IsForced+  = Forced+  | NotForced+  deriving (Data, Show, Eq, Generic)++-- | The backends are responsible for parsing their own pragmas.+data CompilerPragma = CompilerPragma Range String+  deriving (Data, Show, Eq, Generic)++instance HasRange CompilerPragma where+  getRange (CompilerPragma r _) = r++type BackendName    = String++jsBackendName, ghcBackendName :: BackendName+jsBackendName  = "JS"+ghcBackendName = "GHC"++type CompiledRepresentation = Map BackendName [CompilerPragma]++noCompiledRep :: CompiledRepresentation+noCompiledRep = Map.empty++-- A face represented as a list of equality constraints.+-- (r,False) ↦ (r = i0)+-- (r,True ) ↦ (r = i1)+type Face = [(Term,Bool)]++-- | An alternative representation of partial elements in a telescope:+--   Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T+--   see cubicaltt paper (however we do not store the type T).+data System = System+  { systemTel :: Telescope+    -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ+  , systemClauses :: [(Face,Term)]+    -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ+  } deriving (Data, Show, Generic)++-- | Additional information for extended lambdas.+data ExtLamInfo = ExtLamInfo+  { extLamModule    :: ModuleName+    -- ^ For complicated reasons the scope checker decides the QName of a+    --   pattern lambda, and thus its module. We really need to decide the+    --   module during type checking though, since if the lambda appears in a+    --   refined context the module picked by the scope checker has very much+    --   the wrong parameters.+  , extLamAbsurd :: Bool+    -- ^ Was this definition created from an absurd lambda @λ ()@?+  , extLamSys :: !(Strict.Maybe System)+  } deriving (Data, Show, Generic)++modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo+modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e'++-- | Additional information for projection 'Function's.+data Projection = Projection+  { projProper    :: Maybe QName+    -- ^ @Nothing@ if only projection-like, @Just r@ if record projection.+    --   The @r@ is the name of the record type projected from.+    --   This field is updated by module application.+  , projOrig      :: QName+    -- ^ The original projection name+    --   (current name could be from module application).+  , projFromType  :: Arg QName+    -- ^ Type projected from. Original record type if @projProper = Just{}@.+    --   Also stores @ArgInfo@ of the principal argument.+    --   This field is unchanged by module application.+  , projIndex     :: Int+    -- ^ Index of the record argument.+    --   Start counting with 1, because 0 means that+    --   it is already applied to the record value.+    --   This can happen in module instantiation, but+    --   then either the record value is @var 0@, or @funProjection == Nothing@.+  , projLams :: ProjLams+    -- ^ Term @t@ to be be applied to record parameters and record value.+    --   The parameters will be dropped.+    --   In case of a proper projection, a postfix projection application+    --   will be created: @t = \ pars r -> r .p@+    --   (Invariant: the number of abstractions equals 'projIndex'.)+    --   In case of a projection-like function, just the function symbol+    --   is returned as 'Def':  @t = \ pars -> f@.+  } deriving (Data, Show, Generic)++-- | Abstractions to build projection function (dropping parameters).+newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }+  deriving (Data, Show, Null, Generic)++-- | Building the projection function (which drops the parameters).+projDropPars :: Projection -> ProjOrigin -> Term+-- Proper projections:+projDropPars (Projection Just{} d _ _ lams) o =+  case initLast $ getProjLams lams of+    Nothing -> Def d []+    Just (pars, Arg i y) ->+      let core = Lam i $ Abs y $ Var 0 [Proj o d] in+      List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars+-- Projection-like functions:+projDropPars (Projection Nothing d _ _ lams) o =+  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $+    initWithDefault __IMPOSSIBLE__ $ getProjLams lams++-- | The info of the principal (record) argument.+projArgInfo :: Projection -> ArgInfo+projArgInfo (Projection _ _ _ _ lams) =+  maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams++-- | Should a record type admit eta-equality?+data EtaEquality+  = Specified { theEtaEquality :: !HasEta }  -- ^ User specifed 'eta-equality' or 'no-eta-equality'.+  | Inferred  { theEtaEquality :: !HasEta }  -- ^ Positivity checker inferred whether eta is safe.+  deriving (Data, Show, Eq, Generic)++instance PatternMatchingAllowed EtaEquality where+  patternMatchingAllowed = patternMatchingAllowed . theEtaEquality++instance CopatternMatchingAllowed EtaEquality where+  copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality++-- | Make sure we do not overwrite a user specification.+setEtaEquality :: EtaEquality -> HasEta -> EtaEquality+setEtaEquality e@Specified{} _ = e+setEtaEquality _ b = Inferred b++data FunctionFlag+  = FunStatic  -- ^ Should calls to this function be normalised at compile-time?+  | FunInline  -- ^ Should calls to this function be inlined by the compiler?+  | FunMacro   -- ^ Is this function a macro?+  deriving (Data, Eq, Ord, Enum, Show, Generic)++data CompKit = CompKit+  { nameOfHComp :: Maybe QName+  , nameOfTransp :: Maybe QName+  }+  deriving (Data, Eq, Ord, Show, Generic)++emptyCompKit :: CompKit+emptyCompKit = CompKit Nothing Nothing++defaultAxiom :: Defn+defaultAxiom = Axiom False++constTranspAxiom :: Defn+constTranspAxiom = Axiom True++data Defn = Axiom -- ^ Postulate+            { axiomConstTransp :: Bool+              -- ^ Can transp for this postulate be constant?+              --   Set to @True@ for bultins like String.+            }+          | DataOrRecSig+            { datarecPars :: Int }+            -- ^ Data or record type signature that doesn't yet have a definition+          | GeneralizableVar -- ^ Generalizable variable (introduced in `generalize` block)+          | AbstractDefn Defn+            -- ^ Returned by 'getConstInfo' if definition is abstract.+          | Function+            { funClauses        :: [Clause]+            , funCompiled       :: Maybe CompiledClauses+              -- ^ 'Nothing' while function is still type-checked.+              --   @Just cc@ after type and coverage checking and+              --   translation to case trees.+            , funSplitTree      :: Maybe SplitTree+              -- ^ The split tree constructed by the coverage+              --   checker. Needed to re-compile the clauses after+              --   forcing translation.+            , funTreeless       :: Maybe Compiled+              -- ^ Intermediate representation for compiler backends.+            , funCovering       :: [Clause]+              -- ^ Covering clauses computed by coverage checking.+              --   Erased by (IApply) confluence checking(?)+            , funInv            :: FunctionInverse+            , funMutual         :: Maybe [QName]+              -- ^ Mutually recursive functions, @data@s and @record@s.+              --   Does include this function.+              --   Empty list if not recursive.+              --   @Nothing@ if not yet computed (by positivity checker).+            , funAbstr          :: IsAbstract+            , funDelayed        :: Delayed+              -- ^ Are the clauses of this definition delayed?+            , funProjection     :: Maybe Projection+              -- ^ Is it a record projection?+              --   If yes, then return the name of the record type and index of+              --   the record argument.  Start counting with 1, because 0 means that+              --   it is already applied to the record. (Can happen in module+              --   instantiation.) This information is used in the termination+              --   checker.+            , funFlags          :: Set FunctionFlag+            , funTerminates     :: Maybe Bool+              -- ^ Has this function been termination checked?  Did it pass?+            , funExtLam         :: Maybe ExtLamInfo+              -- ^ Is this function generated from an extended lambda?+              --   If yes, then return the number of hidden and non-hidden lambda-lifted arguments+            , funWith           :: Maybe QName+              -- ^ Is this a generated with-function? If yes, then what's the+              --   name of the parent function.+            }+          | Datatype+            { dataPars           :: Nat            -- ^ Number of parameters.+            , dataIxs            :: Nat            -- ^ Number of indices.+            , dataClause         :: (Maybe Clause) -- ^ This might be in an instantiated module.+            , dataCons           :: [QName]+              -- ^ Constructor names , ordered according to the order of their definition.+            , dataSort           :: Sort+            , dataMutual         :: Maybe [QName]+              -- ^ Mutually recursive functions, @data@s and @record@s.+              --   Does include this data type.+              --   Empty if not recursive.+              --   @Nothing@ if not yet computed (by positivity checker).+            , dataAbstr          :: IsAbstract+            , dataPathCons       :: [QName]        -- ^ Path constructor names (subset of dataCons)+            }+          | Record+            { recPars           :: Nat+              -- ^ Number of parameters.+            , recClause         :: Maybe Clause+              -- ^ Was this record type created by a module application?+              --   If yes, the clause is its definition (linking back to the original record type).+            , recConHead        :: ConHead+              -- ^ Constructor name and fields.+            , recNamedCon       :: Bool+              -- ^ Does this record have a @constructor@?+            , recFields         :: [Dom QName]+              -- ^ The record field names.+            , recTel            :: Telescope+              -- ^ The record field telescope. (Includes record parameters.)+              --   Note: @TelV recTel _ == telView' recConType@.+              --   Thus, @recTel@ is redundant.+            , recMutual         :: Maybe [QName]+              -- ^ Mutually recursive functions, @data@s and @record@s.+              --   Does include this record.+              --   Empty if not recursive.+              --   @Nothing@ if not yet computed (by positivity checker).+            , recEtaEquality'    :: EtaEquality+              -- ^ Eta-expand at this record type?+              --   @False@ for unguarded recursive records and coinductive records+              --   unless the user specifies otherwise.+            , recPatternMatching :: PatternOrCopattern+              -- ^ In case eta-equality is off, do we allow pattern matching on the+              --   constructor or construction by copattern matching?+              --   Having both loses subject reduction, see issue #4560.+              --   After positivity checking, this field is obsolete, part of 'EtaEquality'.+            , recInduction      :: Maybe Induction+              -- ^ 'Inductive' or 'CoInductive'?  Matters only for recursive records.+              --   'Nothing' means that the user did not specify it, which is an error+              --   for recursive records.+            , recAbstr          :: IsAbstract+            , recComp           :: CompKit+            }+          | Constructor+            { conPars   :: Int         -- ^ Number of parameters.+            , conArity  :: Int         -- ^ Number of arguments (excluding parameters).+            , conSrcCon :: ConHead     -- ^ Name of (original) constructor and fields. (This might be in a module instance.)+            , conData   :: QName       -- ^ Name of datatype or record type.+            , conAbstr  :: IsAbstract+            , conInd    :: Induction   -- ^ Inductive or coinductive?+            , conComp   :: CompKit     -- ^ Cubical composition.+            , conProj   :: Maybe [QName] -- ^ Projections. 'Nothing' if not yet computed.+            , conForced :: [IsForced]+              -- ^ Which arguments are forced (i.e. determined by the type of the constructor)?+              --   Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@.+            , conErased :: Maybe [Bool]+              -- ^ Which arguments are erased at runtime (computed during compilation to treeless)?+              --   'True' means erased, 'False' means retained.+              --   'Nothing' if no erasure analysis has been performed yet.+              --   The length of the list is @conArity@.+            }+          | Primitive  -- ^ Primitive or builtin functions.+            { primAbstr :: IsAbstract+            , primName  :: String+            , primClauses :: [Clause]+              -- ^ 'null' for primitive functions, @not null@ for builtin functions.+            , primInv      :: FunctionInverse+              -- ^ Builtin functions can have inverses. For instance, natural number addition.+            , primCompiled :: Maybe CompiledClauses+              -- ^ 'Nothing' for primitive functions,+              --   @'Just' something@ for builtin functions.+            }+          | PrimitiveSort+            { primName :: String+            , primSort :: Sort+            }+    deriving (Data, Show, Generic)++instance Pretty Definition where+  pretty Defn{..} =+    "Defn {" <?> vcat+      [ "defArgInfo        =" <?> pshow defArgInfo+      , "defName           =" <?> pretty defName+      , "defType           =" <?> pretty defType+      , "defPolarity       =" <?> pshow defPolarity+      , "defArgOccurrences =" <?> pshow defArgOccurrences+      , "defGeneralizedParams =" <?> pshow defGeneralizedParams+      , "defDisplay        =" <?> pretty defDisplay+      , "defMutual         =" <?> pshow defMutual+      , "defCompiledRep    =" <?> pshow defCompiledRep+      , "defInstance       =" <?> pshow defInstance+      , "defCopy           =" <?> pshow defCopy+      , "defMatchable      =" <?> pshow (Set.toList defMatchable)+      , "defInjective      =" <?> pshow defInjective+      , "defCopatternLHS   =" <?> pshow defCopatternLHS+      , "theDef            =" <?> pretty theDef ] <+> "}"++instance Pretty Defn where+  pretty Axiom{} = "Axiom"+  pretty (DataOrRecSig n)   = "DataOrRecSig" <+> pretty n+  pretty GeneralizableVar{} = "GeneralizableVar"+  pretty (AbstractDefn def) = "AbstractDefn" <?> parens (pretty def)+  pretty Function{..} =+    "Function {" <?> vcat+      [ "funClauses      =" <?> vcat (map pretty funClauses)+      , "funCompiled     =" <?> pretty funCompiled+      , "funSplitTree    =" <?> pretty funSplitTree+      , "funTreeless     =" <?> pshow funTreeless+      , "funInv          =" <?> pretty funInv+      , "funMutual       =" <?> pshow funMutual+      , "funAbstr        =" <?> pshow funAbstr+      , "funDelayed      =" <?> pshow funDelayed+      , "funProjection   =" <?> pretty funProjection+      , "funFlags        =" <?> pshow funFlags+      , "funTerminates   =" <?> pshow funTerminates+      , "funWith         =" <?> pretty funWith ] <?> "}"+  pretty Datatype{..} =+    "Datatype {" <?> vcat+      [ "dataPars       =" <?> pshow dataPars+      , "dataIxs        =" <?> pshow dataIxs+      , "dataClause     =" <?> pretty dataClause+      , "dataCons       =" <?> pshow dataCons+      , "dataSort       =" <?> pretty dataSort+      , "dataMutual     =" <?> pshow dataMutual+      , "dataAbstr      =" <?> pshow dataAbstr ] <?> "}"+  pretty Record{..} =+    "Record {" <?> vcat+      [ "recPars         =" <?> pshow recPars+      , "recClause       =" <?> pretty recClause+      , "recConHead      =" <?> pretty recConHead+      , "recNamedCon     =" <?> pretty recNamedCon+      , "recFields       =" <?> pretty recFields+      , "recTel          =" <?> pretty recTel+      , "recMutual       =" <?> pshow recMutual+      , "recEtaEquality' =" <?> pshow recEtaEquality'+      , "recInduction    =" <?> pshow recInduction+      , "recAbstr        =" <?> pshow recAbstr ] <?> "}"+  pretty Constructor{..} =+    "Constructor {" <?> vcat+      [ "conPars   =" <?> pshow conPars+      , "conArity  =" <?> pshow conArity+      , "conSrcCon =" <?> pshow conSrcCon+      , "conData   =" <?> pshow conData+      , "conAbstr  =" <?> pshow conAbstr+      , "conInd    =" <?> pshow conInd+      , "conErased =" <?> pshow conErased ] <?> "}"+  pretty Primitive{..} =+    "Primitive {" <?> vcat+      [ "primAbstr    =" <?> pshow primAbstr+      , "primName     =" <?> pshow primName+      , "primClauses  =" <?> pshow primClauses+      , "primCompiled =" <?> pshow primCompiled ] <?> "}"+  pretty PrimitiveSort{..} =+    "PrimitiveSort {" <?> vcat+      [ "primName =" <?> pshow primName+      , "primSort =" <?> pshow primSort+      ] <?> "}"++instance Pretty Projection where+  pretty Projection{..} =+    "Projection {" <?> vcat+      [ "projProper   =" <?> pretty projProper+      , "projOrig     =" <?> pretty projOrig+      , "projFromType =" <?> pretty projFromType+      , "projIndex    =" <?> pshow projIndex+      , "projLams     =" <?> pretty projLams+      ]++instance Pretty c => Pretty (FunctionInverse' c) where+  pretty NotInjective = "NotInjective"+  pretty (Inverse inv) = "Inverse" <?>+    vcat [ pretty h <+> "->" <?> pretty cs+         | (h, cs) <- Map.toList inv ]++instance Pretty ProjLams where+  pretty (ProjLams args) = pretty args++-- | Is the record type recursive?+recRecursive :: Defn -> Bool+recRecursive (Record { recMutual = Just qs }) = not $ null qs+recRecursive _ = __IMPOSSIBLE__++recEtaEquality :: Defn -> HasEta+recEtaEquality = theEtaEquality . recEtaEquality'++-- | A template for creating 'Function' definitions, with sensible defaults.+emptyFunction :: Defn+emptyFunction = Function+  { funClauses     = []+  , funCompiled    = Nothing+  , funSplitTree   = Nothing+  , funTreeless    = Nothing+  , funInv         = NotInjective+  , funMutual      = Nothing+  , funAbstr       = ConcreteDef+  , funDelayed     = NotDelayed+  , funProjection  = Nothing+  , funFlags       = Set.empty+  , funTerminates  = Nothing+  , funExtLam      = Nothing+  , funWith        = Nothing+  , funCovering    = []+  }++funFlag :: FunctionFlag -> Lens' Bool Defn+funFlag flag f def@Function{ funFlags = flags } =+  f (Set.member flag flags) <&>+  \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags }+funFlag _ f def = f False $> def++funStatic, funInline, funMacro :: Lens' Bool Defn+funStatic       = funFlag FunStatic+funInline       = funFlag FunInline+funMacro        = funFlag FunMacro++isMacro :: Defn -> Bool+isMacro = (^. funMacro)++-- | Checking whether we are dealing with a function yet to be defined.+isEmptyFunction :: Defn -> Bool+isEmptyFunction def =+  case def of+    Function { funClauses = [] } -> True+    _ -> False++isCopatternLHS :: [Clause] -> Bool+isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)++recCon :: Defn -> QName+recCon Record{ recConHead } = conName recConHead+recCon _ = __IMPOSSIBLE__++defIsRecord :: Defn -> Bool+defIsRecord Record{} = True+defIsRecord _        = False++defIsDataOrRecord :: Defn -> Bool+defIsDataOrRecord Record{}   = True+defIsDataOrRecord Datatype{} = True+defIsDataOrRecord _          = False++defConstructors :: Defn -> [QName]+defConstructors Datatype{dataCons = cs} = cs+defConstructors Record{recConHead = c} = [conName c]+defConstructors _ = __IMPOSSIBLE__++newtype Fields = Fields [(C.Name, Type)]+  deriving Null++-- | Did we encounter a simplifying reduction?+--   In terms of CIC, that would be a iota-reduction.+--   In terms of Agda, this is a constructor or literal+--   pattern that matched.+--   Just beta-reduction (substitution) or delta-reduction+--   (unfolding of definitions) does not count as simplifying?++data Simplification = YesSimplification | NoSimplification+  deriving (Data, Eq, Show, Generic)++instance Null Simplification where+  empty = NoSimplification+  null  = (== NoSimplification)++instance Semigroup Simplification where+  YesSimplification <> _ = YesSimplification+  NoSimplification  <> s = s++instance Monoid Simplification where+  mempty = NoSimplification+  mappend = (<>)++data Reduced no yes+  = NoReduction no+  | YesReduction Simplification yes+  deriving Functor++redReturn :: a -> ReduceM (Reduced a' a)+redReturn = return . YesReduction YesSimplification++-- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@++redBind :: ReduceM (Reduced a a') -> (a -> b) ->+           (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')+redBind ma f k = do+  r <- ma+  case r of+    NoReduction x    -> return $ NoReduction $ f x+    YesReduction _ y -> k y++-- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked.+data IsReduced+  = NotReduced+  | Reduced    (Blocked ())++data MaybeReduced a = MaybeRed+  { isReduced     :: IsReduced+  , ignoreReduced :: a+  }+  deriving (Functor)++instance IsProjElim e => IsProjElim (MaybeReduced e) where+  isProjElim = isProjElim . ignoreReduced++type MaybeReducedArgs = [MaybeReduced (Arg Term)]+type MaybeReducedElims = [MaybeReduced Elim]++notReduced :: a -> MaybeReduced a+notReduced x = MaybeRed NotReduced x++reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)+reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b++-- | Controlling 'reduce'.+data AllowedReduction+  = ProjectionReductions     -- ^ (Projection and) projection-like functions may be reduced.+  | InlineReductions         -- ^ Functions marked INLINE may be reduced.+  | CopatternReductions      -- ^ Copattern definitions may be reduced.+  | FunctionReductions       -- ^ Non-recursive functions and primitives may be reduced.+  | RecursiveReductions      -- ^ Even recursive functions may be reduced.+  | LevelReductions          -- ^ Reduce @'Level'@ terms.+  | TypeLevelReductions      -- ^ Allow @allReductions@ in types, even+                             --   if not allowed at term level (used+                             --   by confluence checker)+  | UnconfirmedReductions    -- ^ Functions whose termination has not (yet) been confirmed.+  | NonTerminatingReductions -- ^ Functions that have failed termination checking.+  deriving (Show, Eq, Ord, Enum, Bounded, Ix, Data, Generic)++type AllowedReductions = SmallSet AllowedReduction++-- | Not quite all reductions (skip non-terminating reductions)+allReductions :: AllowedReductions+allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions++reallyAllReductions :: AllowedReductions+reallyAllReductions = SmallSet.total++data ReduceDefs+  = OnlyReduceDefs (Set QName)+  | DontReduceDefs (Set QName)+  deriving (Data, Generic)++reduceAllDefs :: ReduceDefs+reduceAllDefs = DontReduceDefs empty++locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a+locallyReduceDefs = locallyTC eReduceDefs . const++locallyReduceAllDefs :: MonadTCEnv m => m a -> m a+locallyReduceAllDefs = locallyReduceDefs reduceAllDefs++shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool+shouldReduceDef f = asksTC envReduceDefs <&> \case+  OnlyReduceDefs defs -> f `Set.member` defs+  DontReduceDefs defs -> not $ f `Set.member` defs++instance Semigroup ReduceDefs where+  OnlyReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.intersection qs1 qs2+  OnlyReduceDefs qs1 <> DontReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs1 qs2+  DontReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs2 qs1+  DontReduceDefs qs1 <> DontReduceDefs qs2 = DontReduceDefs $ Set.union        qs1 qs2++instance Monoid ReduceDefs where+  mempty  = reduceAllDefs+  mappend = (<>)+++locallyReconstructed :: MonadTCEnv m => m a -> m a+locallyReconstructed = locallyTC eReconstructed . const $ True++isReconstructed :: (MonadTCEnv m) => m Bool+isReconstructed = asksTC envReconstructed++-- | Primitives++data PrimitiveImpl = PrimImpl Type PrimFun++data PrimFun = PrimFun+  { primFunName           :: QName+  , primFunArity          :: Arity+  , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)+  }+  deriving Generic++primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun+primFun q ar imp = PrimFun q ar (\ args _ -> imp args)++defClauses :: Definition -> [Clause]+defClauses Defn{theDef = Function{funClauses = cs}}        = cs+defClauses Defn{theDef = Primitive{primClauses = cs}}      = cs+defClauses Defn{theDef = Datatype{dataClause = Just c}}    = [c]+defClauses Defn{theDef = Record{recClause = Just c}}       = [c]+defClauses _                                               = []++defCompiled :: Definition -> Maybe CompiledClauses+defCompiled Defn{theDef = Function {funCompiled  = mcc}} = mcc+defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc+defCompiled _ = Nothing++defParameters :: Definition -> Maybe Nat+defParameters Defn{theDef = Datatype{dataPars = n}} = Just n+defParameters Defn{theDef = Record  {recPars  = n}} = Just n+defParameters _                                     = Nothing++defInverse :: Definition -> FunctionInverse+defInverse Defn{theDef = Function { funInv  = inv }} = inv+defInverse Defn{theDef = Primitive{ primInv = inv }} = inv+defInverse _                                         = NotInjective++defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma]+defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep+  -- reversed because we add new pragmas to the front of the list++-- | Are the clauses of this definition delayed?+defDelayed :: Definition -> Delayed+defDelayed Defn{theDef = Function{funDelayed = d}} = d+defDelayed _                                       = NotDelayed++-- | Has the definition failed the termination checker?+defNonterminating :: Definition -> Bool+defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True+defNonterminating _                                                   = False++-- | Has the definition not termination checked or did the check fail?+defTerminationUnconfirmed :: Definition -> Bool+defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False+defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _        }} = True+defTerminationUnconfirmed _ = False++defAbstract :: Definition -> IsAbstract+defAbstract d = case theDef d of+    Axiom{}                   -> ConcreteDef+    DataOrRecSig{}            -> ConcreteDef+    GeneralizableVar{}        -> ConcreteDef+    AbstractDefn{}            -> AbstractDef+    Function{funAbstr = a}    -> a+    Datatype{dataAbstr = a}   -> a+    Record{recAbstr = a}      -> a+    Constructor{conAbstr = a} -> a+    Primitive{primAbstr = a}  -> a+    PrimitiveSort{}           -> ConcreteDef++defForced :: Definition -> [IsForced]+defForced d = case theDef d of+    Constructor{conForced = fs} -> fs+    Axiom{}                     -> []+    DataOrRecSig{}              -> []+    GeneralizableVar{}          -> []+    AbstractDefn{}              -> []+    Function{}                  -> []+    Datatype{}                  -> []+    Record{}                    -> []+    Primitive{}                 -> []+    PrimitiveSort{}             -> []++---------------------------------------------------------------------------+-- ** Injectivity+---------------------------------------------------------------------------++type FunctionInverse = FunctionInverse' Clause+type InversionMap c = Map TermHead [c]++data FunctionInverse' c+  = NotInjective+  | Inverse (InversionMap c)+  deriving (Data, Show, Functor, Generic)++data TermHead = SortHead+              | PiHead+              | ConsHead QName+              | VarHead Nat+              | UnknownHead+  deriving (Data, Eq, Ord, Show, Generic)++instance Pretty TermHead where+  pretty = \ case+    SortHead    -> "SortHead"+    PiHead      -> "PiHead"+    ConsHead q  -> "ConsHead" <+> pretty q+    VarHead i   -> text ("VarHead " ++ show i)+    UnknownHead -> "UnknownHead"++---------------------------------------------------------------------------+-- ** Mutual blocks+---------------------------------------------------------------------------++newtype MutualId = MutId Int32+  deriving (Data, Eq, Ord, Show, Num, Enum, NFData)++---------------------------------------------------------------------------+-- ** Statistics+---------------------------------------------------------------------------++type Statistics = Map String Integer++---------------------------------------------------------------------------+-- ** Trace+---------------------------------------------------------------------------++data Call+  = CheckClause Type A.SpineClause+  | CheckLHS A.SpineLHS+  | CheckPattern A.Pattern Telescope Type+  | CheckPatternLinearityType C.Name+  | CheckPatternLinearityValue C.Name+  | CheckLetBinding A.LetBinding+  | InferExpr A.Expr+  | CheckExprCall Comparison A.Expr Type+  | CheckDotPattern A.Expr Term+  | CheckProjection Range QName Type+  | IsTypeCall Comparison A.Expr Sort+  | IsType_ A.Expr+  | InferVar Name+  | InferDef QName+  | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type)+  | CheckMetaSolution Range MetaId Type Term+  | CheckTargetType Range Type Type+  | CheckDataDef Range QName [A.LamBinding] [A.Constructor]+  | CheckRecDef Range QName [A.LamBinding] [A.Constructor]+  | CheckConstructor QName Telescope Sort A.Constructor+  | CheckConstructorFitsIn QName Type Sort+  | CheckFunDefCall Range QName [A.Clause] Bool+    -- ^ Highlight (interactively) if and only if the boolean is 'True'.+  | CheckPragma Range A.Pragma+  | CheckPrimitive Range QName A.Expr+  | CheckIsEmpty Range Type+  | CheckConfluence QName QName+  | CheckWithFunctionType Type+  | CheckSectionApplication Range ModuleName A.ModuleApplication+  | CheckNamedWhere ModuleName+  | ScopeCheckExpr C.Expr+  | ScopeCheckDeclaration NiceDeclaration+  | ScopeCheckLHS C.QName C.Pattern+  | NoHighlighting+  | ModuleContents  -- ^ Interaction command: show module contents.+  | SetRange Range  -- ^ used by 'setCurrentRange'+  deriving (Data, Generic)++instance Pretty Call where+    pretty CheckClause{}             = "CheckClause"+    pretty CheckLHS{}                = "CheckLHS"+    pretty CheckPattern{}            = "CheckPattern"+    pretty CheckPatternLinearityType{}  = "CheckPatternLinearityType"+    pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue"+    pretty InferExpr{}               = "InferExpr"+    pretty CheckExprCall{}           = "CheckExprCall"+    pretty CheckLetBinding{}         = "CheckLetBinding"+    pretty CheckProjection{}         = "CheckProjection"+    pretty IsTypeCall{}              = "IsTypeCall"+    pretty IsType_{}                 = "IsType_"+    pretty InferVar{}                = "InferVar"+    pretty InferDef{}                = "InferDef"+    pretty CheckArguments{}          = "CheckArguments"+    pretty CheckMetaSolution{}       = "CheckMetaSolution"+    pretty CheckTargetType{}         = "CheckTargetType"+    pretty CheckDataDef{}            = "CheckDataDef"+    pretty CheckRecDef{}             = "CheckRecDef"+    pretty CheckConstructor{}        = "CheckConstructor"+    pretty CheckConstructorFitsIn{}  = "CheckConstructorFitsIn"+    pretty CheckFunDefCall{}         = "CheckFunDefCall"+    pretty CheckPragma{}             = "CheckPragma"+    pretty CheckPrimitive{}          = "CheckPrimitive"+    pretty CheckWithFunctionType{}   = "CheckWithFunctionType"+    pretty CheckNamedWhere{}         = "CheckNamedWhere"+    pretty ScopeCheckExpr{}          = "ScopeCheckExpr"+    pretty ScopeCheckDeclaration{}   = "ScopeCheckDeclaration"+    pretty ScopeCheckLHS{}           = "ScopeCheckLHS"+    pretty CheckDotPattern{}         = "CheckDotPattern"+    pretty SetRange{}                = "SetRange"+    pretty CheckSectionApplication{} = "CheckSectionApplication"+    pretty CheckIsEmpty{}            = "CheckIsEmpty"+    pretty CheckConfluence{}         = "CheckConfluence"+    pretty NoHighlighting{}          = "NoHighlighting"+    pretty ModuleContents{}          = "ModuleContents"++instance HasRange Call where+    getRange (CheckClause _ c)               = getRange c+    getRange (CheckLHS lhs)                  = getRange lhs+    getRange (CheckPattern p _ _)            = getRange p+    getRange (CheckPatternLinearityType x)   = getRange x+    getRange (CheckPatternLinearityValue x)  = getRange x+    getRange (InferExpr e)                   = getRange e+    getRange (CheckExprCall _ e _)           = getRange e+    getRange (CheckLetBinding b)             = getRange b+    getRange (CheckProjection r _ _)         = r+    getRange (IsTypeCall cmp e s)            = getRange e+    getRange (IsType_ e)                     = getRange e+    getRange (InferVar x)                    = getRange x+    getRange (InferDef f)                    = getRange f+    getRange (CheckArguments r _ _ _)        = r+    getRange (CheckMetaSolution r _ _ _)     = r+    getRange (CheckTargetType r _ _)         = r+    getRange (CheckDataDef i _ _ _)          = getRange i+    getRange (CheckRecDef i _ _ _)           = getRange i+    getRange (CheckConstructor _ _ _ c)      = getRange c+    getRange (CheckConstructorFitsIn c _ _)  = getRange c+    getRange (CheckFunDefCall i _ _ _)       = getRange i+    getRange (CheckPragma r _)               = r+    getRange (CheckPrimitive i _ _)          = getRange i+    getRange CheckWithFunctionType{}         = noRange+    getRange (CheckNamedWhere m)             = getRange m+    getRange (ScopeCheckExpr e)              = getRange e+    getRange (ScopeCheckDeclaration d)       = getRange d+    getRange (ScopeCheckLHS _ p)             = getRange p+    getRange (CheckDotPattern e _)           = getRange e+    getRange (SetRange r)                    = r+    getRange (CheckSectionApplication r _ _) = r+    getRange (CheckIsEmpty r _)              = r+    getRange (CheckConfluence rule1 rule2)   = max (getRange rule1) (getRange rule2)+    getRange NoHighlighting                  = noRange+    getRange ModuleContents                  = noRange++---------------------------------------------------------------------------+-- ** Instance table+---------------------------------------------------------------------------++-- | The instance table is a @Map@ associating to every name of+--   record/data type/postulate its list of instances+type InstanceTable = Map QName (Set QName)++-- | When typechecking something of the following form:+--+--     instance+--       x : _+--       x = y+--+--   it's not yet known where to add @x@, so we add it to a list of+--   unresolved instances and we'll deal with it later.+type TempInstanceTable = (InstanceTable , Set QName)++---------------------------------------------------------------------------+-- ** Builtin things+---------------------------------------------------------------------------++data BuiltinDescriptor+  = BuiltinData (TCM Type) [String]+  | BuiltinDataCons (TCM Type)+  | BuiltinPrim String (Term -> TCM ())+  | BuiltinSort String+  | BuiltinPostulate Relevance (TCM Type)+  | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ())+    -- ^ Builtin of any kind.+    --   Type can be checked (@Just t@) or inferred (@Nothing@).+    --   The second argument is the hook for the verification function.++data BuiltinInfo =+   BuiltinInfo { builtinName :: String+               , builtinDesc :: BuiltinDescriptor }++type BuiltinThings pf = Map String (Builtin pf)++data Builtin pf+        = Builtin Term+        | Prim pf+    deriving (Show, Functor, Foldable, Traversable, Generic)++---------------------------------------------------------------------------+-- * Highlighting levels+---------------------------------------------------------------------------++-- | How much highlighting should be sent to the user interface?++data HighlightingLevel+  = None+  | NonInteractive+  | Interactive+    -- ^ This includes both non-interactive highlighting and+    -- interactive highlighting of the expression that is currently+    -- being type-checked.+    deriving (Eq, Ord, Show, Read, Data, Generic)++-- | How should highlighting be sent to the user interface?++data HighlightingMethod+  = Direct+    -- ^ Via stdout.+  | Indirect+    -- ^ Both via files and via stdout.+    deriving (Eq, Show, Read, Data, Generic)++-- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're+-- type-checking the top-level module (or before we've started doing+-- this) and either the highlighting level is /at least/ @l@ or @b@ is+-- 'True'.++ifTopLevelAndHighlightingLevelIsOr ::+  MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()+ifTopLevelAndHighlightingLevelIsOr l b m = do+  e <- askTC+  when (envHighlightingLevel e >= l || b) $+    case (envImportPath e) of+      -- Below the main module.+      (_:_:_) -> pure ()+      -- In or before the top-level module.+      _ -> m++-- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're+-- type-checking the top-level module (or before we've started doing+-- this) and the highlighting level is /at least/ @l@.++ifTopLevelAndHighlightingLevelIs ::+  MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()+ifTopLevelAndHighlightingLevelIs l =+  ifTopLevelAndHighlightingLevelIsOr l False++---------------------------------------------------------------------------+-- * Type checking environment+---------------------------------------------------------------------------++data TCEnv =+    TCEnv { envContext             :: Context+          , envLetBindings         :: LetBindings+          , envCurrentModule       :: ModuleName+          , envCurrentPath         :: Maybe AbsolutePath+            -- ^ The path to the file that is currently being+            -- type-checked.  'Nothing' if we do not have a file+            -- (like in interactive mode see @CommandLine@).+          , envAnonymousModules    :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables+          , envImportPath          :: [C.TopLevelModuleName]+            -- ^ The module stack with the entry being the top-level module as+            --   Agda chases modules. It will be empty if there is no main+            --   module, will have a single entry for the top level module, or+            --   more when descending past the main module. This is used to+            --   detect import cycles and in some cases highlighting behavior.+            --   The level of a given module is not necessarily the same as the+            --   length, in the module dependency graph, of the shortest path+            --   from the top-level module; it depends on in which order Agda+            --   chooses to chase dependencies.+          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block+          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma+          , envCoverageCheck       :: CoverageCheck        -- ^ are we inside the scope of a coverage pragma+          , envMakeCase            :: Bool                 -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier)+          , envSolvingConstraints  :: Bool+                -- ^ Are we currently in the process of solving active constraints?+          , envCheckingWhere       :: Bool+                -- ^ Have we stepped into the where-declarations of a clause?+                --   Everything under a @where@ will be checked with this flag on.+          , envWorkingOnTypes      :: Bool+                -- ^ Are we working on types? Turned on by 'workOnTypes'.+          , envAssignMetas         :: Bool+            -- ^ Are we allowed to assign metas?+          , envActiveProblems      :: Set ProblemId+          , envAbstractMode        :: AbstractMode+                -- ^ When checking the typesignature of a public definition+                --   or the body of a non-abstract definition this is true.+                --   To prevent information about abstract things leaking+                --   outside the module.+          , envModality            :: Modality+                -- ^ 'Relevance' component:+                -- Are we checking an irrelevant argument? (=@Irrelevant@)+                -- Then top-level irrelevant declarations are enabled.+                -- Other value: @Relevant@, then only relevant decls. are available.+                --+                -- 'Quantity' component:+                -- Are we checking a runtime-irrelevant thing? (='Quantity0')+                -- Then runtime-irrelevant things are usable.+                -- Other value: @Quantity1@, runtime relevant.+                -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018.+          , envSplitOnStrict       :: Bool+                -- ^ Are we currently case-splitting on a strict+                --   datatype (i.e. in SSet)? If yes, the+                --   pattern-matching unifier will solve reflexive+                --   equations even --without-K.+          , envDisplayFormsEnabled :: Bool+                -- ^ Sometimes we want to disable display forms.+          , envRange :: Range+          , envHighlightingRange :: Range+                -- ^ Interactive highlighting uses this range rather+                --   than 'envRange'.+          , envClause :: IPClause+                -- ^ What is the current clause we are type-checking?+                --   Will be recorded in interaction points in this clause.+          , envCall  :: Maybe (Closure Call)+                -- ^ what we're doing at the moment+          , envHighlightingLevel  :: HighlightingLevel+                -- ^ Set to 'None' when imported modules are+                --   type-checked.+          , envHighlightingMethod :: HighlightingMethod+          , envExpandLast :: ExpandHidden+                -- ^ When type-checking an alias f=e, we do not want+                -- to insert hidden arguments in the end, because+                -- these will become unsolved metas.+          , envAppDef :: Maybe QName+                -- ^ We are reducing an application of this function.+                -- (For debugging of incomplete matches only.)+          , envSimplification :: Simplification+                -- ^ Did we encounter a simplification (proper match)+                --   during the current reduction process?+          , envAllowedReductions :: AllowedReductions+          , envReduceDefs :: ReduceDefs+          , envReconstructed :: Bool+          , envInjectivityDepth :: Int+                -- ^ Injectivity can cause non-termination for unsolvable contraints+                --   (#431, #3067). Keep a limit on the nesting depth of injectivity+                --   uses.+          , envCompareBlocked :: Bool+                -- ^ When @True@, the conversion checker will consider+                --   all term constructors as injective, including+                --   blocked function applications and metas. Warning:+                --   this should only be used when not assigning any+                --   metas (e.g. when @envAssignMetas@ is @False@ or+                --   when running @pureEqualTerms@) or else we get+                --   non-unique meta solutions.+          , envPrintDomainFreePi :: Bool+                -- ^ When @True@, types will be omitted from printed pi types if they+                --   can be inferred.+          , envPrintMetasBare :: Bool+                -- ^ When @True@, throw away meta numbers and meta elims.+                --   This is used for reifying terms for feeding into the+                --   user's source code, e.g., for the interaction tactics @solveAll@.+          , envInsideDotPattern :: Bool+                -- ^ Used by the scope checker to make sure that certain forms+                --   of expressions are not used inside dot patterns: extended+                --   lambdas and let-expressions.+          , envUnquoteFlags :: UnquoteFlags+          , envInstanceDepth :: !Int+                -- ^ Until we get a termination checker for instance search (#1743) we+                --   limit the search depth to ensure termination.+          , envIsDebugPrinting :: Bool+          , envPrintingPatternLambdas :: [QName]+                -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We+                --   don't have a good story for what to do in this case, but at least+                --   printing shouldn't loop. Here we keep track of which pattern lambdas+                --   we are currently in the process of printing.+          , envCallByNeed :: Bool+                -- ^ Use call-by-need evaluation for reductions.+          , envCurrentCheckpoint :: CheckpointId+                -- ^ Checkpoints track the evolution of the context as we go+                -- under binders or refine it by pattern matching.+          , envCheckpoints :: Map CheckpointId Substitution+                -- ^ Keeps the substitution from each previous checkpoint to+                --   the current context.+          , envGeneralizeMetas :: DoGeneralize+                -- ^ Should new metas generalized over.+          , envGeneralizedVars :: Map QName GeneralizedValue+                -- ^ Values for used generalizable variables.+          , envActiveBackendName :: Maybe BackendName+                -- ^ Is some backend active at the moment, and if yes, which?+                --   NB: we only store the 'BackendName' here, otherwise+                --   @instance Data TCEnv@ is not derivable.+                --   The actual backend can be obtained from the name via 'stBackends'.+          , envConflComputingOverlap :: Bool+                -- ^ Are we currently computing the overlap between+                --   two rewrite rules for the purpose of confluence checking?+          }+    deriving (Generic)++initEnv :: TCEnv+initEnv = TCEnv { envContext             = []+                , envLetBindings         = Map.empty+                , envCurrentModule       = noModuleName+                , envCurrentPath         = Nothing+                , envAnonymousModules    = []+                , envImportPath          = []+                , envMutualBlock         = Nothing+                , envTerminationCheck    = TerminationCheck+                , envCoverageCheck       = YesCoverageCheck+                , envMakeCase            = False+                , envSolvingConstraints  = False+                , envCheckingWhere       = False+                , envActiveProblems      = Set.empty+                , envWorkingOnTypes      = False+                , envAssignMetas         = True+                , envAbstractMode        = ConcreteMode+  -- Andreas, 2013-02-21:  This was 'AbstractMode' until now.+  -- However, top-level checks for mutual blocks, such as+  -- constructor-headedness, should not be able to look into+  -- abstract definitions unless abstract themselves.+  -- (See also discussion on issue 796.)+  -- The initial mode should be 'ConcreteMode', ensuring you+  -- can only look into abstract things in an abstract+  -- definition (which sets 'AbstractMode').+                , envModality               = unitModality+                , envSplitOnStrict          = False+                , envDisplayFormsEnabled    = True+                , envRange                  = noRange+                , envHighlightingRange      = noRange+                , envClause                 = IPNoClause+                , envCall                   = Nothing+                , envHighlightingLevel      = None+                , envHighlightingMethod     = Indirect+                , envExpandLast             = ExpandLast+                , envAppDef                 = Nothing+                , envSimplification         = NoSimplification+                , envAllowedReductions      = allReductions+                , envReduceDefs             = reduceAllDefs+                , envReconstructed          = False+                , envInjectivityDepth       = 0+                , envCompareBlocked         = False+                , envPrintDomainFreePi      = False+                , envPrintMetasBare         = False+                , envInsideDotPattern       = False+                , envUnquoteFlags           = defaultUnquoteFlags+                , envInstanceDepth          = 0+                , envIsDebugPrinting        = False+                , envPrintingPatternLambdas = []+                , envCallByNeed             = True+                , envCurrentCheckpoint      = 0+                , envCheckpoints            = Map.singleton 0 IdS+                , envGeneralizeMetas        = NoGeneralize+                , envGeneralizedVars        = Map.empty+                , envActiveBackendName      = Nothing+                , envConflComputingOverlap  = False+                }++class LensTCEnv a where+  lensTCEnv :: Lens' TCEnv a++instance LensTCEnv TCEnv where+  lensTCEnv = id++instance LensModality TCEnv where+  -- Cohesion shouldn't have an environment component.+  getModality = setCohesion defaultCohesion . envModality+  mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e }++instance LensRelevance TCEnv where+instance LensQuantity  TCEnv where++data UnquoteFlags = UnquoteFlags+  { _unquoteNormalise :: Bool }+  deriving (Data, Generic)++defaultUnquoteFlags :: UnquoteFlags+defaultUnquoteFlags = UnquoteFlags+  { _unquoteNormalise = False }++unquoteNormalise :: Lens' Bool UnquoteFlags+unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }++eUnquoteNormalise :: Lens' Bool TCEnv+eUnquoteNormalise = eUnquoteFlags . unquoteNormalise++-- * e-prefixed lenses+------------------------------------------------------------------------++eContext :: Lens' Context TCEnv+eContext f e = f (envContext e) <&> \ x -> e { envContext = x }++eLetBindings :: Lens' LetBindings TCEnv+eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }++eCurrentModule :: Lens' ModuleName TCEnv+eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }++eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv+eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }++eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv+eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }++eImportPath :: Lens' [C.TopLevelModuleName] TCEnv+eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }++eMutualBlock :: Lens' (Maybe MutualId) TCEnv+eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }++eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv+eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }++eCoverageCheck :: Lens' CoverageCheck TCEnv+eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }++eMakeCase :: Lens' Bool TCEnv+eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }++eSolvingConstraints :: Lens' Bool TCEnv+eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }++eCheckingWhere :: Lens' Bool TCEnv+eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }++eWorkingOnTypes :: Lens' Bool TCEnv+eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }++eAssignMetas :: Lens' Bool TCEnv+eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }++eActiveProblems :: Lens' (Set ProblemId) TCEnv+eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }++eAbstractMode :: Lens' AbstractMode TCEnv+eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }++-- Andrea 23/02/2020: use get/setModality to enforce invariants of the+--                    envModality field.+eModality :: Lens' Modality TCEnv+eModality f e = f (getModality e) <&> \ x -> setModality x e++eRelevance :: Lens' Relevance TCEnv+eRelevance = eModality . lModRelevance++eQuantity :: Lens' Quantity TCEnv+eQuantity = eModality . lModQuantity++eSplitOnStrict :: Lens' Bool TCEnv+eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x }++eDisplayFormsEnabled :: Lens' Bool TCEnv+eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }++eRange :: Lens' Range TCEnv+eRange f e = f (envRange e) <&> \ x -> e { envRange = x }++eHighlightingRange :: Lens' Range TCEnv+eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }++eCall :: Lens' (Maybe (Closure Call)) TCEnv+eCall f e = f (envCall e) <&> \ x -> e { envCall = x }++eHighlightingLevel :: Lens' HighlightingLevel TCEnv+eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }++eHighlightingMethod :: Lens' HighlightingMethod TCEnv+eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }++eExpandLast :: Lens' ExpandHidden TCEnv+eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }++eAppDef :: Lens' (Maybe QName) TCEnv+eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }++eSimplification :: Lens' Simplification TCEnv+eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }++eAllowedReductions :: Lens' AllowedReductions TCEnv+eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }++eReduceDefs :: Lens' ReduceDefs TCEnv+eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x }++eReconstructed :: Lens' Bool TCEnv+eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x }++eInjectivityDepth :: Lens' Int TCEnv+eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }++eCompareBlocked :: Lens' Bool TCEnv+eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }++ePrintDomainFreePi :: Lens' Bool TCEnv+ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }++eInsideDotPattern :: Lens' Bool TCEnv+eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }++eUnquoteFlags :: Lens' UnquoteFlags TCEnv+eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }++eInstanceDepth :: Lens' Int TCEnv+eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }++eIsDebugPrinting :: Lens' Bool TCEnv+eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }++ePrintingPatternLambdas :: Lens' [QName] TCEnv+ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }++eCallByNeed :: Lens' Bool TCEnv+eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }++eCurrentCheckpoint :: Lens' CheckpointId TCEnv+eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }++eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv+eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }++eGeneralizeMetas :: Lens' DoGeneralize TCEnv+eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }++eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv+eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }++eActiveBackendName :: Lens' (Maybe BackendName) TCEnv+eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }++eConflComputingOverlap :: Lens' Bool TCEnv+eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x }++---------------------------------------------------------------------------+-- ** Context+---------------------------------------------------------------------------++-- | The @Context@ is a stack of 'ContextEntry's.+type Context      = [ContextEntry]+type ContextEntry = Dom (Name, Type)++---------------------------------------------------------------------------+-- ** Let bindings+---------------------------------------------------------------------------++type LetBindings = Map Name (Open (Term, Dom Type))++---------------------------------------------------------------------------+-- ** Abstract mode+---------------------------------------------------------------------------++data AbstractMode+  = AbstractMode        -- ^ Abstract things in the current module can be accessed.+  | ConcreteMode        -- ^ No abstract things can be accessed.+  | IgnoreAbstractMode  -- ^ All abstract things can be accessed.+  deriving (Data, Show, Eq, Generic)++aDefToMode :: IsAbstract -> AbstractMode+aDefToMode AbstractDef = AbstractMode+aDefToMode ConcreteDef = ConcreteMode++aModeToDef :: AbstractMode -> Maybe IsAbstract+aModeToDef AbstractMode = Just AbstractDef+aModeToDef ConcreteMode = Just ConcreteDef+aModeToDef _ = Nothing++---------------------------------------------------------------------------+-- ** Insertion of implicit arguments+---------------------------------------------------------------------------++data ExpandHidden+  = ExpandLast      -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.+  | DontExpandLast  -- ^ Do not append implicit arguments.+  | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables.+  deriving (Eq, Data, Generic)++isDontExpandLast :: ExpandHidden -> Bool+isDontExpandLast ExpandLast           = False+isDontExpandLast DontExpandLast       = True+isDontExpandLast ReallyDontExpandLast = True++data CandidateKind+  = LocalCandidate+  | GlobalCandidate QName+  deriving (Show, Data, Generic)++-- | A candidate solution for an instance meta is a term with its type.+--   It may be the case that the candidate is not fully applied yet or+--   of the wrong type, hence the need for the type.+data Candidate  = Candidate { candidateKind :: CandidateKind+                            , candidateTerm :: Term+                            , candidateType :: Type+                            , candidateOverlappable :: Bool+                            }+  deriving (Show, Data, Generic)++instance Free Candidate where+  freeVars' (Candidate _ t u _) = freeVars' (t, u)+++---------------------------------------------------------------------------+-- ** Checking arguments+---------------------------------------------------------------------------++data ArgsCheckState a = ACState+       { acRanges :: [Maybe Range]+         -- ^ Ranges of checked arguments, where present.+         -- e.g. inserted implicits have no correponding abstract syntax.+       , acElims  :: Elims+         -- ^ Checked and inserted arguments so far.+       , acConstraints :: [Maybe (Abs Constraint)]+         -- ^ Constraints for the head so far,+         -- i.e. before applying the correponding elim.+       , acType   :: Type+         -- ^ Type for the rest of the application.+       , acData   :: a+       }+  deriving (Show)+++---------------------------------------------------------------------------+-- * Type checking warnings (aka non-fatal errors)+---------------------------------------------------------------------------++-- | A non-fatal error is an error which does not prevent us from+-- checking the document further and interacting with the user.++data Warning+  = NicifierIssue            DeclarationWarning+  | TerminationIssue         [TerminationError]+  | UnreachableClauses       QName [Range]+  -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs+  --   are unreachable+  | CoverageIssue            QName [(Telescope, [NamedArg DeBruijnPattern])]+  -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`+  | CoverageNoExactSplit     QName [Clause]+  | NotStrictlyPositive      QName (Seq OccursWhere)+  | UnsolvedMetaVariables    [Range]  -- ^ Do not use directly with 'warning'+  | UnsolvedInteractionMetas [Range]  -- ^ Do not use directly with 'warning'+  | UnsolvedConstraints      Constraints+    -- ^ Do not use directly with 'warning'+  | CantGeneralizeOverSorts [MetaId]+  | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern]+  | OldBuiltin               String String+    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new+  | EmptyRewritePragma+    -- ^ If the user wrote just @{-\# REWRITE \#-}@.+  | EmptyWhere+    -- ^ An empty @where@ block is dead code.+  | IllformedAsClause String+    -- ^ If the user wrote something other than an unqualified name+    --   in the @as@ clause of an @import@ statement.+    --   The 'String' gives optionally extra explanation.+  | ClashesViaRenaming NameOrModule [C.Name]+    -- ^ If a `renaming' import directive introduces a name or module name clash+    --   in the exported names of a module.+    --   (See issue #4154.)+  | UselessPatternDeclarationForRecord String+    -- ^ The 'pattern' declaration is useless in the presence+    --   of either @coinductive@ or @eta-equality@.+    --   Content of 'String' is "coinductive" or "eta", resp.+  | UselessPublic+    -- ^ If the user opens a module public before the module header.+    --   (See issue #2377.)+  | UselessHiding [C.ImportedName]+    -- ^ Names in `hiding` directive that don't hide anything+    --   imported by a `using` directive.+  | UselessInline            QName+  | WrongInstanceDeclaration+  | InstanceWithExplicitArg  QName+  -- ^ An instance was declared with an implicit argument, which means it+  --   will never actually be considered by instance search.+  | InstanceNoOutputTypeName Doc+  -- ^ The type of an instance argument doesn't end in a named or+  -- variable type, so it will never be considered by instance search.+  | InstanceArgWithExplicitArg Doc+  -- ^ As InstanceWithExplicitArg, but for local bindings rather than+  --   top-level instances.+  | InversionDepthReached    QName+  -- ^ The --inversion-max-depth was reached.+  | NoGuardednessFlag        QName+  -- ^ A coinductive record was declared but neither --guardedness nor+  --   --sized-types is enabled.++  -- Generic warnings for one-off things+  | GenericWarning           Doc+    -- ^ Harmless generic warning (not an error)+  | GenericNonFatalError     Doc+    -- ^ Generic error which doesn't abort proceedings (not a warning)+  | GenericUseless  Range    Doc+    -- ^ Generic warning when code is useless and thus ignored.+    --   'Range' is for dead code highlighting.++  -- Safe flag errors+  | SafeFlagPostulate C.Name+  | SafeFlagPragma [String]                -- ^ Unsafe OPTIONS.+  | SafeFlagNonTerminating+  | SafeFlagTerminating+  | SafeFlagWithoutKFlagPrimEraseEquality+  | WithoutKFlagPrimEraseEquality+  | SafeFlagNoPositivityCheck+  | SafeFlagPolarity+  | SafeFlagNoUniverseCheck+  | SafeFlagNoCoverageCheck+  | SafeFlagInjective+  | SafeFlagEta                            -- ^ ETA pragma is unsafe.+  | ParseWarning             ParseWarning+  | LibraryWarning           LibWarning+  | DeprecationWarning String String String+    -- ^ `DeprecationWarning old new version`:+    --   `old` is deprecated, use `new` instead. This will be an error in Agda `version`.+  | UserWarning Text+    -- ^ User-defined warning (e.g. to mention that a name is deprecated)+  | DuplicateUsing (List1 C.ImportedName)+    -- ^ Duplicate mentions of the same name in @using@ directive(s).+  | FixityInRenamingModule (List1 Range)+    -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity).+  | ModuleDoesntExport C.QName [C.Name] [C.Name] [C.ImportedName]+    -- ^ Some imported names are not actually exported by the source module.+    --   The second argument is the names that could be exported.+    --   The third  argument is the module names that could be exported.+  | InfectiveImport String ModuleName+    -- ^ Importing a file using an infective option into one which doesn't+  | CoInfectiveImport String ModuleName+    -- ^ Importing a file not using a coinfective option from one which does+  | RewriteNonConfluent Term Term Term Doc+    -- ^ Confluence checker found critical pair and equality checking+    --   resulted in a type error+  | RewriteMaybeNonConfluent Term Term [Doc]+    -- ^ Confluence checker got stuck on computing overlap between two+    --   rewrite rules+  | RewriteAmbiguousRules Term Term Term+    -- ^ The global confluence checker found a term @u@ that reduces+    --   to both @v1@ and @v2@ and there is no rule to resolve the+    --   ambiguity.+  | RewriteMissingRule Term Term Term+    -- ^ The global confluence checker found a term @u@ that reduces+    --   to @v@, but @v@ does not reduce to @rho(u)@.+  | PragmaCompileErased BackendName QName+    -- ^ COMPILE directive for an erased symbol+  | NotInScopeW [C.QName]+    -- ^ Out of scope error we can recover from+  | AsPatternShadowsConstructorOrPatternSynonym Bool+    -- ^ The as-name in an as-pattern may not shadow a constructor (@False@)+    --   or pattern synonym name (@True@),+    --   because this can be confusing to read.+  | RecordFieldWarning RecordFieldWarning+  deriving (Show, Generic)++data RecordFieldWarning+  = DuplicateFieldsWarning [(C.Name, Range)]+      -- ^ Each redundant field comes with a range of associated dead code.+  | TooManyFieldsWarning QName [C.Name] [(C.Name, Range)]+      -- ^ Record type, fields not supplied by user, non-fields but supplied.+      --   The redundant fields come with a range of associated dead code.+  deriving (Show, Data, Generic)++recordFieldWarningToError :: RecordFieldWarning -> TypeError+recordFieldWarningToError = \case+  DuplicateFieldsWarning    xrs -> DuplicateFields    $ map fst xrs+  TooManyFieldsWarning q ys xrs -> TooManyFields q ys $ map fst xrs++warningName :: Warning -> WarningName+warningName = \case+  -- special cases+  NicifierIssue dw             -> declarationWarningName dw+  ParseWarning pw              -> parseWarningName pw+  LibraryWarning lw            -> libraryWarningName lw+  AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_+  -- scope- and type-checking errors+  AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_+  CantGeneralizeOverSorts{}    -> CantGeneralizeOverSorts_+  CoverageIssue{}              -> CoverageIssue_+  CoverageNoExactSplit{}       -> CoverageNoExactSplit_+  DeprecationWarning{}         -> DeprecationWarning_+  EmptyRewritePragma           -> EmptyRewritePragma_+  EmptyWhere                   -> EmptyWhere_+  IllformedAsClause{}          -> IllformedAsClause_+  WrongInstanceDeclaration{}   -> WrongInstanceDeclaration_+  InstanceWithExplicitArg{}    -> InstanceWithExplicitArg_+  InstanceNoOutputTypeName{}   -> InstanceNoOutputTypeName_+  InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_+  DuplicateUsing{}             -> DuplicateUsing_+  FixityInRenamingModule{}     -> FixityInRenamingModule_+  GenericNonFatalError{}       -> GenericNonFatalError_+  GenericUseless{}             -> GenericUseless_+  GenericWarning{}             -> GenericWarning_+  InversionDepthReached{}      -> InversionDepthReached_+  ModuleDoesntExport{}         -> ModuleDoesntExport_+  NoGuardednessFlag{}          -> NoGuardednessFlag_+  NotInScopeW{}                -> NotInScope_+  NotStrictlyPositive{}        -> NotStrictlyPositive_+  OldBuiltin{}                 -> OldBuiltin_+  SafeFlagNoPositivityCheck    -> SafeFlagNoPositivityCheck_+  SafeFlagNonTerminating       -> SafeFlagNonTerminating_+  SafeFlagNoUniverseCheck      -> SafeFlagNoUniverseCheck_+  SafeFlagPolarity             -> SafeFlagPolarity_+  SafeFlagPostulate{}          -> SafeFlagPostulate_+  SafeFlagPragma{}             -> SafeFlagPragma_+  SafeFlagEta                  -> SafeFlagEta_+  SafeFlagInjective            -> SafeFlagInjective_+  SafeFlagNoCoverageCheck      -> SafeFlagNoCoverageCheck_+  SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_+  WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_+  SafeFlagTerminating          -> SafeFlagTerminating_+  TerminationIssue{}           -> TerminationIssue_+  UnreachableClauses{}         -> UnreachableClauses_+  UnsolvedInteractionMetas{}   -> UnsolvedInteractionMetas_+  UnsolvedConstraints{}        -> UnsolvedConstraints_+  UnsolvedMetaVariables{}      -> UnsolvedMetaVariables_+  UselessHiding{}              -> UselessHiding_+  UselessInline{}              -> UselessInline_+  UselessPublic{}              -> UselessPublic_+  UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_+  ClashesViaRenaming{}         -> ClashesViaRenaming_+  UserWarning{}                -> UserWarning_+  InfectiveImport{}            -> InfectiveImport_+  CoInfectiveImport{}          -> CoInfectiveImport_+  RewriteNonConfluent{}        -> RewriteNonConfluent_+  RewriteMaybeNonConfluent{}   -> RewriteMaybeNonConfluent_+  RewriteAmbiguousRules{}      -> RewriteAmbiguousRules_+  RewriteMissingRule{}         -> RewriteMissingRule_+  PragmaCompileErased{}        -> PragmaCompileErased_+  -- record field warnings+  RecordFieldWarning w -> case w of+    DuplicateFieldsWarning{}   -> DuplicateFieldsWarning_+    TooManyFieldsWarning{}     -> TooManyFieldsWarning_++data TCWarning+  = TCWarning+    { tcWarningLocation :: CallStack+        -- ^ Location in the internal Agda source code location where the error raised+    , tcWarningRange    :: Range+        -- ^ Range where the warning was raised+    , tcWarning         :: Warning+        -- ^ The warning itself+    , tcWarningPrintedWarning :: Doc+        -- ^ The warning printed in the state and environment where it was raised+    , tcWarningCached :: Bool+        -- ^ Should the warning be affected by caching.+    }+  deriving (Show, Generic)++tcWarningOrigin :: TCWarning -> SrcFile+tcWarningOrigin = rangeFile . tcWarningRange++instance HasRange TCWarning where+  getRange = tcWarningRange++-- used for merging lists of warnings+instance Eq TCWarning where+  (==) = (==) `on` tcWarningPrintedWarning++---------------------------------------------------------------------------+-- * Type checking errors+---------------------------------------------------------------------------++-- | Information about a call.++data CallInfo = CallInfo+  { callInfoTarget :: QName+    -- ^ Target function name.+  , callInfoRange :: Range+    -- ^ Range of the target function.+  , callInfoCall :: Closure Term+    -- ^ To be formatted representation of the call.+  } deriving (Show, Generic)+    -- no Eq, Ord instances: too expensive! (see issues 851, 852)++-- | We only 'show' the name of the callee.+instance Pretty CallInfo where pretty = pretty . callInfoTarget++-- | Information about a mutual block which did not pass the+-- termination checker.++data TerminationError = TerminationError+  { termErrFunctions :: [QName]+    -- ^ The functions which failed to check. (May not include+    -- automatically generated functions.)+  , termErrCalls :: [CallInfo]+    -- ^ The problematic call sites.+  } deriving (Show, Generic)++-- | Error when splitting a pattern variable into possible constructor patterns.+data SplitError+  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.+  | BlockedType Blocker (Closure Type)  -- ^ Type could not be sufficiently reduced.+  | ErasedDatatype Bool (Closure Type)  -- ^ Data type, but in erased position.+                                        --   If the boolean is 'True',+                                        --   then the reason for the+                                        --   error is that the K rule+                                        --   is turned off.+  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.+  -- UNUSED, but keep!+  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor+  | UnificationStuck+    { cantSplitBlocker  :: Maybe Blocker -- ^ Blocking metavariable (if any)+    , cantSplitConName  :: QName        -- ^ Constructor.+    , cantSplitTel      :: Telescope    -- ^ Context for indices.+    , cantSplitConIdx   :: Args         -- ^ Inferred indices (from type of constructor).+    , cantSplitGivenIdx :: Args         -- ^ Expected indices (from checking pattern).+    , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck.+    }+  | CosplitCatchall+      -- ^ Copattern split with a catchall+  | CosplitNoTarget+      -- ^ We do not know the target type of the clause.+  | CosplitNoRecordType (Closure Type)+      -- ^ Target type is not a record type.+  | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type))++  | GenericSplitError String+  deriving (Show, Generic)++data NegativeUnification+  = UnifyConflict Telescope Term Term+  | UnifyCycle Telescope Int Term+  deriving (Show, Generic)++data UnificationFailure+  = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype+  | UnifyRecursiveEq Telescope Type Int Term          -- ^ Can't solve equation because variable occurs in (type of) lhs+  | UnifyReflexiveEq Telescope Type Term              -- ^ Can't solve reflexive equation because --without-K is enabled+  | UnifyUnusableModality Telescope Type Int Term Modality  -- ^ Can't solve equation because solution modality is less "usable"+  deriving (Show, Generic)++data UnquoteError+  = BadVisibility String (Arg I.Term)+  | ConInsteadOfDef QName String String+  | DefInsteadOfCon QName String String+  | NonCanonical String I.Term+  | BlockedOnMeta TCState Blocker+  | UnquotePanic String+  deriving (Show, Generic)++data TypeError+        = InternalError String+        | NotImplemented String+        | NotSupported String+        | CompilationError String+        | PropMustBeSingleton+        | DataMustEndInSort Term+{- UNUSED+        | DataTooManyParameters+            -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the+            --   the parameters given in the forward declaraion @data D Gamma : T@.+-}+        | ShouldEndInApplicationOfTheDatatype Type+            -- ^ The target of a constructor isn't an application of its+            -- datatype. The 'Type' records what it does target.+        | ShouldBeAppliedToTheDatatypeParameters Term Term+            -- ^ The target of a constructor isn't its datatype applied to+            --   something that isn't the parameters. First term is the correct+            --   target and the second term is the actual target.+        | ShouldBeApplicationOf Type QName+            -- ^ Expected a type to be an application of a particular datatype.+        | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype+        | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)+          -- ^ Datatype, constructors.+        | DoesNotConstructAnElementOf QName Type -- ^ constructor, type+        | WrongHidingInLHS+            -- ^ The left hand side of a function definition has a hidden argument+            --   where a non-hidden was expected.+        | WrongHidingInLambda Type+            -- ^ Expected a non-hidden function and found a hidden lambda.+        | WrongHidingInApplication Type+            -- ^ A function is applied to a hidden argument where a non-hidden was expected.+        | WrongNamedArgument (NamedArg A.Expr) [NamedName]+            -- ^ A function is applied to a hidden named argument it does not have.+            -- The list contains names of possible hidden arguments at this point.+        | WrongIrrelevanceInLambda+            -- ^ Wrong user-given relevance annotation in lambda.+        | WrongQuantityInLambda+            -- ^ Wrong user-given quantity annotation in lambda.+        | WrongCohesionInLambda+            -- ^ Wrong user-given cohesion annotation in lambda.+        | QuantityMismatch Quantity Quantity+            -- ^ The given quantity does not correspond to the expected quantity.+        | HidingMismatch Hiding Hiding+            -- ^ The given hiding does not correspond to the expected hiding.+        | RelevanceMismatch Relevance Relevance+            -- ^ The given relevance does not correspond to the expected relevane.+        | UninstantiatedDotPattern A.Expr+        | ForcedConstructorNotInstantiated A.Pattern+        | IllformedProjectionPattern A.Pattern+        | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type+        | WrongNumberOfConstructorArguments QName Nat Nat+        | ShouldBeEmpty Type [DeBruijnPattern]+        | ShouldBeASort Type+            -- ^ The given type should have been a sort.+        | ShouldBePi Type+            -- ^ The given type should have been a pi.+        | ShouldBePath Type+        | ShouldBeRecordType Type+        | ShouldBeRecordPattern DeBruijnPattern+        | NotAProjectionPattern (NamedArg A.Pattern)+        | NotAProperTerm+        | InvalidTypeSort Sort+            -- ^ This sort is not a type expression.+        | InvalidType Term+            -- ^ This term is not a type expression.+        | FunctionTypeInSizeUniv Term+            -- ^ This term, a function type constructor, lives in+            --   @SizeUniv@, which is not allowed.+        | SplitOnIrrelevant (Dom Type)+        | SplitOnUnusableCohesion (Dom Type)+        -- UNUSED: -- | SplitOnErased (Dom Type)+        | SplitOnNonVariable Term Type+        | SplitOnNonEtaRecord QName+        | DefinitionIsIrrelevant QName+        | DefinitionIsErased QName+        | VariableIsIrrelevant Name+        | VariableIsErased Name+        | VariableIsOfUnusableCohesion Name Cohesion+        | UnequalLevel Comparison Level Level+        | UnequalTerms Comparison Term Term CompareAs+        | UnequalTypes Comparison Type Type+--      | UnequalTelescopes Comparison Telescope Telescope -- UNUSED+        | UnequalRelevance Comparison Term Term+            -- ^ The two function types have different relevance.+        | UnequalQuantity Comparison Term Term+            -- ^ The two function types have different relevance.+        | UnequalCohesion Comparison Term Term+            -- ^ The two function types have different cohesion.+        | UnequalHiding Term Term+            -- ^ The two function types have different hiding.+        | UnequalSorts Sort Sort+        | UnequalBecauseOfUniverseConflict Comparison Term Term+        | NotLeqSort Sort Sort+        | MetaCannotDependOn MetaId Nat+            -- ^ The arguments are the meta variable and the parameter that it wants to depend on.+        | MetaOccursInItself MetaId+        | MetaIrrelevantSolution MetaId Term+        | MetaErasedSolution MetaId Term+        | GenericError String+        | GenericDocError Doc+        | SortOfSplitVarError (Maybe Blocker) Doc+          -- ^ the meta is what we might be blocked on.+        | BuiltinMustBeConstructor String A.Expr+        | NoSuchBuiltinName String+        | DuplicateBuiltinBinding String Term Term+        | NoBindingForBuiltin String+        | NoSuchPrimitiveFunction String+        | DuplicatePrimitiveBinding String QName QName+        | WrongModalityForPrimitive String ArgInfo ArgInfo+        | ShadowedModule C.Name [A.ModuleName]+        | BuiltinInParameterisedModule String+        | IllegalLetInTelescope C.TypedBinding+        | IllegalPatternInTelescope C.Binder+        | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]+        | TooManyFields QName [C.Name] [C.Name]+          -- ^ Record type, fields not supplied by user, non-fields but supplied.+        | DuplicateFields [C.Name]+        | DuplicateConstructors [C.Name]+        | WithOnFreeVariable A.Expr Term+        | UnexpectedWithPatterns [A.Pattern]+        | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)+        | FieldOutsideRecord+        | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]+        | GeneralizeCyclicDependency+        | GeneralizeUnsolvedMeta+    -- Coverage errors+-- UNUSED:        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off+        | SplitError SplitError+        | ImpossibleConstructor QName NegativeUnification+    -- Positivity errors+        | TooManyPolarities QName Int+    -- Import errors+        | LocalVsImportedModuleClash ModuleName+        | SolvedButOpenHoles+          -- ^ Some interaction points (holes) have not been filled by user.+          --   There are not 'UnsolvedMetas' since unification solved them.+          --   This is an error, since interaction points are never filled+          --   without user interaction.+        | CyclicModuleDependency [C.TopLevelModuleName]+        | FileNotFound C.TopLevelModuleName [AbsolutePath]+        | OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName+        | AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath]+        | ModuleNameUnexpected C.TopLevelModuleName C.TopLevelModuleName+          -- ^ Found module name, expected module name.+        | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]+        | ClashingFileNamesFor ModuleName [AbsolutePath]+        | ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath+          -- ^ Module name, file from which it was loaded, file which+          -- the include path says contains the module.+    -- Scope errors+        | BothWithAndRHS+        | AbstractConstructorNotInScope A.QName+        | NotInScope [C.QName]+        | NoSuchModule C.QName+        | AmbiguousName C.QName (List1 A.QName)+        | AmbiguousModule C.QName (List1 A.ModuleName)+        | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration)+        | ClashingModule A.ModuleName A.ModuleName+        | ClashingImport C.Name A.QName+        | ClashingModuleImport C.Name A.ModuleName+        | PatternShadowsConstructor C.Name A.QName+        | DuplicateImports C.QName [C.ImportedName]+        | InvalidPattern C.Pattern+        | RepeatedVariablesInPattern [C.Name]+        | GeneralizeNotSupportedHere A.QName+        | MultipleFixityDecls [(C.Name, [Fixity'])]+        | MultiplePolarityPragmas [C.Name]+    -- Concrete to Abstract errors+        | NotAModuleExpr C.Expr+            -- ^ The expr was used in the right hand side of an implicit module+            --   definition, but it wasn't of the form @m Delta@.+        | NotAnExpression C.Expr+        | NotAValidLetBinding NiceDeclaration+        | NotValidBeforeField NiceDeclaration+        | NothingAppliedToHiddenArg C.Expr+        | NothingAppliedToInstanceArg C.Expr+    -- Pattern synonym errors+        | BadArgumentsToPatternSynonym A.AmbiguousQName+        | TooFewArgumentsToPatternSynonym A.AmbiguousQName+        | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))+        | UnusedVariableInPatternSynonym+    -- Operator errors+        | NoParseForApplication (List2 C.Expr)+        | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr)+        | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern+            -- ^ The list contains patterns that failed to be interpreted.+            --   If it is non-empty, the first entry could be printed as error hint.+        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]+            -- ^ Pattern and its possible interpretations.+        | OperatorInformation [NotationSection] TypeError+{- UNUSED+        | NoParseForPatternSynonym C.Pattern+        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]+-}+    -- Usage errors+    -- Instance search errors+        | InstanceNoCandidate Type [(Term, TCErr)]+    -- Reflection errors+        | UnquoteFailed UnquoteError+        | DeBruijnIndexOutOfScope Nat Telescope [Name]+    -- Language option errors+        | NeedOptionCopatterns+        | NeedOptionRewriting+        | NeedOptionProp+        | NeedOptionTwoLevel+    -- Failure associated to warnings+        | NonFatalErrors [TCWarning]+    -- Instance search errors+        | InstanceSearchDepthExhausted Term Type Int+        | TriedToCopyConstrainedPrim QName+          deriving (Show, Generic)++-- | Distinguish error message when parsing lhs or pattern synonym, resp.+data LHSOrPatSyn = IsLHS | IsPatSyn+  deriving (Eq, Show, Generic)++-- | Type-checking errors.++data TCErr+  = TypeError+    { tcErrLocation :: CallStack+       -- ^ Location in the internal Agda source code where the error was raised+    , tcErrState    :: TCState+        -- ^ The state in which the error was raised.+    , tcErrClosErr  :: Closure TypeError+        -- ^ The environment in which the error as raised plus the error.+    }+  | Exception Range Doc+  | IOException TCState Range E.IOException+    -- ^ The first argument is the state in which the error was+    -- raised.+  | PatternErr Blocker+      -- ^ The exception which is usually caught.+      --   Raised for pattern violations during unification ('assignV')+      --   but also in other situations where we want to backtrack.+      --   Contains an unblocker to control when the computation should+      --   be retried.++instance Show TCErr where+  show (TypeError _ _ e)   = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e)+  show (Exception r d)     = prettyShow r ++ ": " ++ render d+  show (IOException _ r e) = prettyShow r ++ ": " ++ show e+  show PatternErr{}        = "Pattern violation (you shouldn't see this)"++instance HasRange TCErr where+  getRange (TypeError _ _ cl)  = envRange $ clEnv cl+  getRange (Exception r _)     = r+  getRange (IOException s r _) = r+  getRange PatternErr{}        = noRange++instance E.Exception TCErr++-----------------------------------------------------------------------------+-- * Accessing options+-----------------------------------------------------------------------------++instance MonadIO m => HasOptions (TCMT m) where+  pragmaOptions = useTC stPragmaOptions++  commandLineOptions = do+    p  <- useTC stPragmaOptions+    cl <- stPersistentOptions . stPersistentState <$> getTC+    return $ cl { optPragmaOptions = p }++-- HasOptions lifts through monad transformers+-- (see default signatures in the HasOptions class).++-- Ternary options are annoying to deal with so we provide auxiliary+-- definitions using @collapseDefault@.++sizedTypesOption :: HasOptions m => m Bool+sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions++guardednessOption :: HasOptions m => m Bool+guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions++withoutKOption :: HasOptions m => m Bool+withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions++enableCaching :: HasOptions m => m Bool+enableCaching = optCaching <$> pragmaOptions+-----------------------------------------------------------------------------+-- * The reduce monad+-----------------------------------------------------------------------------++-- | Environment of the reduce monad.+data ReduceEnv = ReduceEnv+  { redEnv :: TCEnv    -- ^ Read only access to environment.+  , redSt  :: TCState  -- ^ Read only access to state (signature, metas...).+  }++mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv+mapRedEnv f s = s { redEnv = f (redEnv s) }++mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv+mapRedSt f s = s { redSt = f (redSt s) }++mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv+            -> ReduceEnv+mapRedEnvSt f g (ReduceEnv e s) = ReduceEnv (f e) (g s)++-- Lenses+reduceEnv :: Lens' TCEnv ReduceEnv+reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }++reduceSt :: Lens' TCState ReduceEnv+reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }++newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }+--  deriving (Functor, Applicative, Monad)++onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+onReduceEnv f (ReduceM m) = ReduceM (m . f)++fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b+fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e+{-# INLINE fmapReduce #-}++-- Andreas, 2021-05-12, issue #5379:+-- It seems more stable to force to evaluate @mf <*> ma@+-- from left to right, for the sake of printing+-- debug messages in order.+apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b+apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e ->+  let g = f e+      a = x e+  in  g `pseq` a `pseq` g a+{-# INLINE apReduce #-}++-- Andreas, 2021-05-12, issue #5379+-- Since the MonadDebug instance of ReduceM is implemented via+-- unsafePerformIO, we need to force results that later+-- computations do not depend on, otherwise we lose debug messages.+thenReduce :: ReduceM a -> ReduceM b -> ReduceM b+thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e+{-# INLINE thenReduce #-}++-- Andreas, 2021-05-14:+-- `seq` does not force evaluation order, the optimizier is allowed to replace+-- @+--    a `seq` b`+-- @+-- by:+-- @+--    b `seq` a `seq` b+-- @+-- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html+--+-- In contrast, `pseq` is only strict in its first argument, so such a permutation+-- is forbidden.+-- If we want to ensure that debug messages are printed before exceptions are+-- propagated, we need to use `pseq`, as in:+-- @+--    unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG+-- @+beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a+beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e ->+  let a = x e+  in  a `pseq` y e `pseq` a+{-# INLINE beforeReduce #-}++bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b+bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e+{-# INLINE bindReduce #-}++instance Functor ReduceM where+  fmap = fmapReduce++instance Applicative ReduceM where+  pure x = ReduceM (const x)+  (<*>) = apReduce+  (*>)  = thenReduce+  (<*)  = beforeReduce++instance Monad ReduceM where+  return = pure+  (>>=) = bindReduce+  (>>) = (*>)+#if __GLASGOW_HASKELL__ < 808+  fail = Fail.fail+#endif++instance Fail.MonadFail ReduceM where+  fail = error++instance ReadTCState ReduceM where+  getTCState = ReduceM redSt+  locallyTCState l f = onReduceEnv $ mapRedSt $ over l f++runReduceM :: ReduceM a -> TCM a+runReduceM m = TCM $ \ r e -> do+  s <- readIORef r+  E.evaluate $ unReduceM m $ ReduceEnv e s+  -- Andreas, 2021-05-13, issue #5379+  -- This was the following, which is apparently not strict enough+  -- to force all unsafePerformIOs...+  -- runReduceM m = do+  --   e <- askTC+  --   s <- getTC+  --   return $! unReduceM m (ReduceEnv e s)++runReduceF :: (a -> ReduceM b) -> TCM (a -> b)+runReduceF f = do+  e <- askTC+  s <- getTC+  return $ \x -> unReduceM (f x) (ReduceEnv e s)++instance MonadTCEnv ReduceM where+  askTC   = ReduceM redEnv+  localTC = onReduceEnv . mapRedEnv++-- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084):+--+--   useR forces the result of projecting the lens,+--   this usually prevents retaining the whole structure when we only need a field.+--+-- This fixes (or contributes to the fix of) the space leak issue #1829 (caching).+useR :: (ReadTCState m) => Lens' a TCState -> m a+useR l = do+  !x <- (^.l) <$> getTCState+  return x++askR :: ReduceM ReduceEnv+askR = ReduceM ask++localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+localR f = ReduceM . local f . unReduceM++instance HasOptions ReduceM where+  pragmaOptions      = useR stPragmaOptions+  commandLineOptions = do+    p  <- useR stPragmaOptions+    cl <- stPersistentOptions . stPersistentState <$> getTCState+    return $ cl{ optPragmaOptions = p }++class ( Applicative m+      , MonadTCEnv m+      , ReadTCState m+      , HasOptions m+      ) => MonadReduce m where+  liftReduce :: ReduceM a -> m a++  default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a+  liftReduce = lift . liftReduce++instance MonadReduce ReduceM where+  liftReduce = id++instance MonadReduce m => MonadReduce (ChangeT m)+instance MonadReduce m => MonadReduce (ExceptT err m)+instance MonadReduce m => MonadReduce (IdentityT m)+instance MonadReduce m => MonadReduce (ListT m)+instance MonadReduce m => MonadReduce (MaybeT m)+instance MonadReduce m => MonadReduce (ReaderT r m)+instance MonadReduce m => MonadReduce (StateT w m)+instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m)+instance MonadReduce m => MonadReduce (BlockT m)++---------------------------------------------------------------------------+-- * Monad with read-only 'TCEnv'+---------------------------------------------------------------------------++-- | @MonadTCEnv@ made into its own dedicated service class.+--   This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@.+class Monad m => MonadTCEnv m where+  askTC   :: m TCEnv+  localTC :: (TCEnv -> TCEnv) -> m a -> m a++  default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv+  askTC = lift askTC++  default localTC+    :: (MonadTransControl t, MonadTCEnv n, t n ~ m)+    =>  (TCEnv -> TCEnv) -> m a -> m a+  localTC = liftThrough . localTC++instance MonadTCEnv m => MonadTCEnv (ChangeT m)+instance MonadTCEnv m => MonadTCEnv (ExceptT err m)+instance MonadTCEnv m => MonadTCEnv (IdentityT m)+instance MonadTCEnv m => MonadTCEnv (MaybeT m)+instance MonadTCEnv m => MonadTCEnv (ReaderT r m)+instance MonadTCEnv m => MonadTCEnv (StateT s m)+instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m)++instance MonadTCEnv m => MonadTCEnv (ListT m) where+  localTC = mapListT . localTC++asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a+asksTC f = f <$> askTC++viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a+viewTC l = asksTC (^. l)++-- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.+locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b+locallyTC l = localTC . over l++---------------------------------------------------------------------------+-- * Monad with mutable 'TCState'+---------------------------------------------------------------------------++-- | @MonadTCState@ made into its own dedicated service class.+--   This allows us to use 'MonadState' for 'StateT' extensions of @TCM@.+class Monad m => MonadTCState m where+  getTC :: m TCState+  putTC :: TCState -> m ()+  modifyTC :: (TCState -> TCState) -> m ()++  default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState+  getTC = lift getTC++  default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()+  putTC = lift . putTC++  default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()+  modifyTC = lift . modifyTC++instance MonadTCState m => MonadTCState (MaybeT m)+instance MonadTCState m => MonadTCState (ListT m)+instance MonadTCState m => MonadTCState (ExceptT err m)+instance MonadTCState m => MonadTCState (ReaderT r m)+instance MonadTCState m => MonadTCState (StateT s m)+instance MonadTCState m => MonadTCState (ChangeT m)+instance MonadTCState m => MonadTCState (IdentityT m)+instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m)++-- ** @TCState@ accessors (no lenses)++getsTC :: ReadTCState m => (TCState -> a) -> m a+getsTC f = f <$> getTCState++-- | A variant of 'modifyTC' in which the computation is strict in the+-- new state.+modifyTC' :: MonadTCState m => (TCState -> TCState) -> m ()+modifyTC' f = do+  s' <- getTC+  putTC $! f s'++-- SEE TC.Monad.State+-- -- | Restore the 'TCState' after computation.+-- localTCState :: MonadTCState m => m a -> m a+-- localTCState = bracket_ getTC putTC++-- ** @TCState@ accessors via lenses++useTC :: ReadTCState m => Lens' a TCState -> m a+useTC l = do+  !x <- getsTC (^. l)+  return x++infix 4 `setTCLens`++-- | Overwrite the part of the 'TCState' focused on by the lens.+setTCLens :: MonadTCState m => Lens' a TCState -> a -> m ()+setTCLens l = modifyTC . set l++-- | Modify the part of the 'TCState' focused on by the lens.+modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()+modifyTCLens l = modifyTC . over l++-- | Modify a part of the state monadically.+modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m ()+modifyTCLensM l f = putTC =<< l f =<< getTC++-- | Modify the part of the 'TCState' focused on by the lens, and return some result.+stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r+stateTCLens l f = stateTCLensM l $ return . f++-- | Modify a part of the state monadically, and return some result.+stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r+stateTCLensM l f = do+  s <- getTC+  (result , x) <- f $ s ^. l+  putTC $ set l x s+  return result+++---------------------------------------------------------------------------+-- ** Monad with capability to block a computation+---------------------------------------------------------------------------++class Monad m => MonadBlock m where++  -- | `patternViolation b` aborts the current computation+  patternViolation :: Blocker -> m a++  default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a+  patternViolation = lift . patternViolation++  -- | `catchPatternErr handle m` runs m, handling pattern violations+  --    with `handle` (doesn't roll back the state)+  catchPatternErr :: (Blocker -> m a) -> m a -> m a++newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a }+  deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2+           , MonadIO, Fail.MonadFail+           , ReadTCState, HasOptions+           , MonadTCEnv, MonadTCState, MonadTCM+           )++instance Monad m => MonadBlock (BlockT m) where+  patternViolation = BlockT . throwError+  catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h)++instance Monad m => MonadBlock (ExceptT TCErr m) where+  patternViolation = throwError . PatternErr+  catchPatternErr h f = catchError f $ \case+    PatternErr b -> h b+    err          -> throwError err++runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)+runBlocked = runExceptT . unBlockT++instance MonadBlock m => MonadBlock (MaybeT m) where+  catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m++instance MonadBlock m => MonadBlock (ReaderT e m) where+  catchPatternErr h m = ReaderT $ \ e ->+    let run = flip runReaderT e in catchPatternErr (run . h) (run m)++---------------------------------------------------------------------------+-- * Type checking monad transformer+---------------------------------------------------------------------------++-- | The type checking monad transformer.+-- Adds readonly 'TCEnv' and mutable 'TCState'.+newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }++-- | Type checking monad.+type TCM = TCMT IO++{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}+mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a+mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e)++pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a+pureTCM f = TCM $ \ r e -> do+  s <- liftIO $ readIORef r+  return (f s e)++-- One goal of the definitions and pragmas below is to inline the+-- monad operations as much as possible. This doesn't seem to have a+-- large effect on the performance of the normal executable, but (at+-- least on one machine/configuration) it has a massive effect on the+-- performance of the profiling executable [1], and reduces the time+-- attributed to bind from over 90% to about 25%.+--+-- [1] When compiled with -auto-all and run with -p: roughly 750%+-- faster for one example.++returnTCMT :: MonadIO m => a -> TCMT m a+returnTCMT = \x -> TCM $ \_ _ -> return x+{-# INLINE returnTCMT #-}++bindTCMT :: MonadIO 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 :: MonadIO 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 MonadIO m => Functor (TCMT m) where+  fmap = fmapTCMT++fmapTCMT :: MonadIO m => (a -> b) -> TCMT m a -> TCMT m b+fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e)+{-# INLINE fmapTCMT #-}++instance MonadIO m => Applicative (TCMT m) where+  pure  = returnTCMT+  (<*>) = apTCMT++apTCMT :: MonadIO m => TCMT m (a -> b) -> TCMT m a -> TCMT m b+apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> ap (mf r e) (m r e)+{-# INLINE apTCMT #-}++instance MonadTrans TCMT where+    lift m = TCM $ \_ _ -> m++-- We want a special monad implementation of fail.+instance MonadIO m => Monad (TCMT m) where+    return = pure+    (>>=)  = bindTCMT+    (>>)   = (*>)+#if __GLASGOW_HASKELL__ < 808+    fail   = Fail.fail+#endif++instance MonadIO m => Fail.MonadFail (TCMT m) where+  fail = internalError++instance MonadIO m => MonadIO (TCMT m) where+  liftIO m = TCM $ \ s env -> do+    liftIO $ wrap s (envRange env) $ do+      x <- m+      x `seq` return x+    where+      wrap s r m = E.catch m $ \ err -> do+        s <- readIORef s+        E.throwIO $ IOException s r err++instance MonadIO m => MonadTCEnv (TCMT m) where+  askTC             = TCM $ \ _ e -> return e+  localTC f (TCM m) = TCM $ \ s e -> m s (f e)++instance MonadIO m => MonadTCState (TCMT m) where+  getTC   = TCM $ \ r _e -> liftIO (readIORef r)+  putTC s = TCM $ \ r _e -> liftIO (writeIORef r s)+  modifyTC f = putTC . f =<< getTC++instance MonadIO m => ReadTCState (TCMT m) where+  getTCState = getTC+  locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l)++instance MonadBlock TCM where+  patternViolation b = throwError (PatternErr b)+  catchPatternErr handle v =+       catchError_ v $ \err ->+       case err of+            -- Not putting s (which should really be the what's already there) makes things go+            -- a lot slower (+20% total time on standard library). How is that possible??+            -- The problem is most likely that there are internal catchErrors which forgets the+            -- state. catchError should preserve the state on pattern violations.+           PatternErr u -> handle u+           _            -> throwError err+++instance MonadError TCErr TCM where+  throwError = liftIO . E.throwIO+  catchError m h = TCM $ \ r e -> do  -- now we are in the IO monad+    oldState <- readIORef r+    unTCM m r e `E.catch` \err -> do+      -- Reset the state, but do not forget changes to the persistent+      -- component. Not for pattern violations.+      case err of+        PatternErr{} -> return ()+        _            ->+          liftIO $ do+            newState <- readIORef r+            writeIORef r $ oldState { stPersistentState = stPersistentState newState }+      unTCM (h err) r e++-- | Like 'catchError', but resets the state completely before running the handler.+--   This means it also loses changes to the 'stPersistentState'.+--+--   The intended use is to catch internal errors during debug printing.+--   In debug printing, we are not expecting state changes.+instance CatchImpossible TCM where+  catchImpossibleJust f m h = TCM $ \ r e -> do+    -- save the state+    s <- readIORef r+    catchImpossibleJust f (unTCM m r e) $ \ err -> do+      writeIORef r s+      unTCM (h err) r e++instance MonadIO m => MonadReduce (TCMT m) where+  liftReduce = liftTCM . runReduceM++instance (IsString a, MonadIO m) => IsString (TCMT m a) where+  fromString s = return (fromString s)++-- | Strict (non-shortcut) semigroup.+--+--   Note that there might be a lazy alternative, e.g.,+--   for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation,+--   to shortcut conjunction in case we already have 'False'.+--+instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where+  (<>) = liftA2 (<>)++-- | Strict (non-shortcut) monoid.+instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where+  mempty  = pure mempty+  mappend = (<>)+  mconcat = mconcat <.> sequence++instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where+  empty = return empty+  null  = __IMPOSSIBLE__++-- | Preserve the state of the failing computation.+catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a+catchError_ m h = TCM $ \r e ->+  unTCM m r e+  `E.catch` \err -> unTCM (h err) r e++-- | Execute a finalizer even when an exception is thrown.+--   Does not catch any errors.+--   In case both the regular computation and the finalizer+--   throw an exception, the one of the finalizer is propagated.+finally_ :: TCM a -> TCM b -> TCM a+finally_ m f = do+    x <- m `catchError_` \ err -> f >> throwError err+    _ <- f+    return x++-- | Embedding a TCM computation.++class ( Applicative tcm, MonadIO tcm+      , MonadTCEnv tcm+      , MonadTCState tcm+      , HasOptions tcm+      ) => MonadTCM tcm where+    liftTCM :: TCM a -> tcm a++    default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a+    liftTCM = lift . liftTCM++{-# RULES "liftTCM/id" liftTCM = id #-}+instance MonadIO m => MonadTCM (TCMT m) where+    liftTCM = mapTCMT liftIO++instance MonadTCM tcm => MonadTCM (ChangeT tcm)+instance MonadTCM tcm => MonadTCM (ExceptT err tcm)+instance MonadTCM tcm => MonadTCM (IdentityT tcm)+instance MonadTCM tcm => MonadTCM (ListT tcm)+instance MonadTCM tcm => MonadTCM (MaybeT tcm)+instance MonadTCM tcm => MonadTCM (ReaderT r tcm)+instance MonadTCM tcm => MonadTCM (StateT s tcm)+instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm)++-- | We store benchmark statistics in an IORef.+--   This enables benchmarking pure computation, see+--   "Agda.Benchmarking".+instance MonadBench TCM where+  type BenchPhase TCM = Phase+  getBenchmark = liftIO $ getBenchmark+  putBenchmark = liftIO . putBenchmark+  finally = finally_++instance Null (TCM Doc) where+  empty = return empty+  null = __IMPOSSIBLE__++internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a+internalError s = withCallerCallStack $ \ loc ->+  liftTCM $ typeError' loc $ InternalError s++-- | The constraints needed for 'typeError' and similar.+type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)++-- | Utility function for 1-arg constructed type errors.+-- Note that the @HasCallStack@ constraint is on the *resulting* function.+locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b)+locatedTypeError f e = withCallerCallStack (flip typeError' (f e))++genericError :: (HasCallStack, MonadTCError m) => String -> m a+genericError = locatedTypeError GenericError++{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}+genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a+genericDocError = locatedTypeError GenericDocError++{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-}+typeError' :: MonadTCError m => CallStack -> TypeError -> m a+typeError' loc err = throwError =<< typeError'_ loc err++{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-}+typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a+typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err++{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-}+typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr+typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err++{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-}+typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr+typeError_ = withCallerCallStack . flip typeError'_++-- | Running the type checking monad (most general form).+{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}+runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)+runTCM e s m = do+  r <- liftIO $ newIORef s+  a <- unTCM m r e+  s <- liftIO $ readIORef r+  return (a, s)++-- | Running the type checking monad on toplevel (with initial state).+runTCMTop :: TCM a -> IO (Either TCErr a)+runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left)++runTCMTop' :: MonadIO m => TCMT m a -> m a+runTCMTop' m = do+  r <- liftIO $ newIORef initState+  unTCM m r initEnv++-- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which+--   cannot fail, except that it might raise 'IOException's) in the+--   initial environment.++runSafeTCM :: TCM a -> TCState -> IO (a, TCState)+runSafeTCM m st =+  runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of+    IOException _ _ err -> E.throwIO err+    _                   -> __IMPOSSIBLE__++-- | Runs the given computation in a separate thread, with /a copy/ of+-- the current state and environment.+--+-- Note that Agda sometimes uses actual, mutable state. If the+-- computation given to @forkTCM@ tries to /modify/ this state, then+-- bad things can happen, because accesses are not mutually exclusive.+-- The @forkTCM@ function has been added mainly to allow the thread to+-- /read/ (a snapshot of) the current state in a convenient way.+--+-- Note also that exceptions which are raised in the thread are not+-- propagated to the parent, so the thread should not do anything+-- important.++forkTCM :: TCM a -> TCM ()+forkTCM m = do+  s <- getTC+  e <- askTC+  liftIO $ void $ C.forkIO $ void $ runTCM e s m++---------------------------------------------------------------------------+-- * Names for generated definitions+---------------------------------------------------------------------------++-- | Base name for patterns in telescopes+patternInTeleName :: String+patternInTeleName = ".patternInTele"++-- | Base name for extended lambda patterns+extendedLambdaName :: String+extendedLambdaName = ".extendedlambda"++-- | Check whether we have an definition from an extended lambda.+isExtendedLambdaName :: A.QName -> Bool+isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName++-- | Name of absurdLambda definitions.+absurdLambdaName :: String+absurdLambdaName = ".absurdlambda"++-- | Check whether we have an definition from an absurd lambda.+isAbsurdLambdaName :: QName -> Bool+isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName++-- | Base name for generalized variable projections+generalizedFieldName :: String+generalizedFieldName = ".generalizedField-"++-- | Check whether we have a generalized variable field+getGeneralizedFieldName :: A.QName -> Maybe String+getGeneralizedFieldName q+  | generalizedFieldName `List.isPrefixOf` strName = Just (drop (length generalizedFieldName) strName)+  | otherwise                                      = Nothing+  where strName = prettyShow $ nameConcrete $ qnameName q++---------------------------------------------------------------------------+-- * KillRange instances+---------------------------------------------------------------------------++instance KillRange Signature where+  killRange (Sig secs defs rews) = killRange2 Sig secs defs rews++instance KillRange Sections where+  killRange = fmap killRange++instance KillRange Definitions where+  killRange = fmap killRange++instance KillRange RewriteRuleMap where+  killRange = fmap killRange++instance KillRange Section where+  killRange (Section tel) = killRange1 Section tel++instance KillRange Definition where+  killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk def) =+    killRange18 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk def+    -- TODO clarify: Keep the range in the defName field?++instance KillRange NumGeneralizableArgs where+  killRange = id++instance KillRange NLPat where+  killRange (PVar x y) = killRange2 PVar x y+  killRange (PDef x y) = killRange2 PDef x y+  killRange (PLam x y) = killRange2 PLam x y+  killRange (PPi x y)  = killRange2 PPi x y+  killRange (PSort x)  = killRange1 PSort x+  killRange (PBoundVar x y) = killRange2 PBoundVar x y+  killRange (PTerm x)  = killRange1 PTerm x++instance KillRange NLPType where+  killRange (NLPType s a) = killRange2 NLPType s a++instance KillRange NLPSort where+  killRange (PType l) = killRange1 PType l+  killRange (PProp l) = killRange1 PProp l+  killRange s@(PInf f n) = s+  killRange PSizeUniv = PSizeUniv+  killRange PLockUniv = PLockUniv++instance KillRange RewriteRule where+  killRange (RewriteRule q gamma f es rhs t c) =+    killRange6 RewriteRule q gamma f es rhs t c++instance KillRange CompiledRepresentation where+  killRange = id+++instance KillRange EtaEquality where+  killRange = id++instance KillRange System where+  killRange (System tel sys) = System (killRange tel) (killRange sys)++instance KillRange ExtLamInfo where+  killRange (ExtLamInfo m b sys) = killRange3 ExtLamInfo m b sys++instance KillRange FunctionFlag where+  killRange = id++instance KillRange CompKit where+  killRange = id++instance KillRange Defn where+  killRange def =+    case def of+      Axiom a -> Axiom a+      DataOrRecSig n -> DataOrRecSig n+      GeneralizableVar -> GeneralizableVar+      AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!+      Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with ->+        killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with+      Datatype a b c d e f g h       -> killRange7 Datatype a b c d e f g h+      Record a b c d e f g h i j k l -> killRange12 Record a b c d e f g h i j k l+      Constructor a b c d e f g h i j-> killRange10 Constructor a b c d e f g h i j+      Primitive a b c d e            -> killRange5 Primitive a b c d e+      PrimitiveSort a b              -> killRange2 PrimitiveSort a b++instance KillRange MutualId where+  killRange = id++instance KillRange c => KillRange (FunctionInverse' c) where+  killRange NotInjective = NotInjective+  killRange (Inverse m)  = Inverse $ killRangeMap m++instance KillRange TermHead where+  killRange SortHead     = SortHead+  killRange PiHead       = PiHead+  killRange (ConsHead q) = ConsHead $ killRange q+  killRange h@VarHead{}  = h+  killRange UnknownHead  = UnknownHead++instance KillRange Projection where+  killRange (Projection a b c d e) = killRange5 Projection a b c d e++instance KillRange ProjLams where+  killRange = id++instance KillRange a => KillRange (Open a) where+  killRange = fmap killRange++instance KillRange DisplayForm where+  killRange (Display n es dt) = killRange3 Display n es dt++instance KillRange Polarity where+  killRange = id++instance KillRange IsForced where+  killRange = id++instance KillRange DoGeneralize where+  killRange = id++instance KillRange DisplayTerm where+  killRange dt =+    case dt of+      DWithApp dt dts es -> killRange3 DWithApp dt dts es+      DCon q ci dts     -> killRange3 DCon q ci dts+      DDef q dts        -> killRange2 DDef q dts+      DDot v            -> killRange1 DDot v+      DTerm v           -> killRange1 DTerm v++instance KillRange a => KillRange (Closure a) where+  killRange = id++---------------------------------------------------------------------------+-- NFData instances+---------------------------------------------------------------------------++instance NFData NumGeneralizableArgs where+  rnf NoGeneralizableArgs       = ()+  rnf (SomeGeneralizableArgs _) = ()++instance NFData TCErr where+  rnf (TypeError a b c)   = rnf a `seq` rnf b `seq` rnf c+  rnf (Exception a b)     = rnf a `seq` rnf b+  rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c)+                            -- At the time of writing there is no+                            -- NFData instance for E.IOException.+  rnf (PatternErr a)      = rnf a++-- | This instance could be optimised, some things are guaranteed to+-- be forced.++instance NFData PreScopeState++-- | This instance could be optimised, some things are guaranteed to+-- be forced.++instance NFData PostScopeState++instance NFData TCState+instance NFData DisambiguatedName+instance NFData MutualBlock+instance NFData PersistentTCState+instance NFData LoadedFileCache+instance NFData TypeCheckAction+instance NFData ModuleCheckMode+instance NFData ModuleInfo+instance NFData ForeignCode+instance NFData Interface+instance NFData a => NFData (Closure a)+instance NFData ProblemConstraint+instance NFData Constraint+instance NFData Signature+instance NFData Comparison+instance NFData CompareAs+instance NFData a => NFData (Open a)+instance NFData a => NFData (Judgement a)+instance NFData DoGeneralize+instance NFData GeneralizedValue+instance NFData MetaVariable+instance NFData Listener+instance NFData MetaInstantiation+instance NFData Frozen+instance NFData PrincipalArgTypeMetas+instance NFData TypeCheckingProblem+instance NFData RunMetaOccursCheck+instance NFData MetaInfo+instance NFData InteractionPoint+instance NFData InteractionPoints+instance NFData Overapplied+instance NFData t => NFData (IPBoundary' t)+instance NFData IPClause+instance NFData DisplayForm+instance NFData DisplayTerm+instance NFData NLPat+instance NFData NLPType+instance NFData NLPSort+instance NFData RewriteRule+instance NFData Definition+instance NFData Polarity+instance NFData IsForced+instance NFData Projection+instance NFData ProjLams+instance NFData CompilerPragma+instance NFData System+instance NFData ExtLamInfo+instance NFData EtaEquality+instance NFData FunctionFlag+instance NFData CompKit+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 pf => NFData (Builtin pf)+instance NFData HighlightingLevel+instance NFData HighlightingMethod+instance NFData TCEnv+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 LHSOrPatSyn

src/full/Agda/TypeChecking/Monad/Base.hs-boot view

@@ -1,6 +1,5 @@ module Agda.TypeChecking.Monad.Base where -import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Data.IORef (IORef) import Data.Map (Map)@@ -39,5 +38,4 @@ type BackendName = String  data Comparison-newtype ProblemId = ProblemId Nat data Polarity

src/full/Agda/TypeChecking/Monad/Benchmark.hs view

@@ -3,6 +3,7 @@ module Agda.TypeChecking.Monad.Benchmark   ( module Agda.Benchmarking   , B.MonadBench+  , B.BenchPhase   , B.getBenchmark   , updateBenchmarkingStatus   , B.billTo, B.billPureTo, B.billToCPS

src/full/Agda/TypeChecking/Monad/Builtin.hs view

@@ -6,8 +6,10 @@  import qualified Control.Monad.Fail as Fail +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Identity (IdentityT) import Control.Monad.Trans.Maybe import Control.Monad.Writer @@ -23,7 +25,6 @@ -- import Agda.TypeChecking.Functions  -- LEADS TO IMPORT CYCLE import Agda.TypeChecking.Substitute -import Agda.Utils.Except import Agda.Utils.ListT import Agda.Utils.Monad import Agda.Utils.Maybe@@ -37,23 +38,22 @@       ) => HasBuiltins m where   getBuiltinThing :: String -> m (Maybe (Builtin PrimFun)) -instance HasBuiltins m => HasBuiltins (MaybeT m) where-  getBuiltinThing b = lift $ getBuiltinThing b--instance HasBuiltins m => HasBuiltins (ExceptT e m) where-  getBuiltinThing b = lift $ getBuiltinThing b--instance HasBuiltins m => HasBuiltins (ListT m) where-  getBuiltinThing b = lift $ getBuiltinThing b+  default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => String -> m (Maybe (Builtin PrimFun))+  getBuiltinThing = lift . getBuiltinThing -instance HasBuiltins m => HasBuiltins (ReaderT e m) where-  getBuiltinThing b = lift $ getBuiltinThing b+instance HasBuiltins m => HasBuiltins (ExceptT e m)+instance HasBuiltins m => HasBuiltins (IdentityT m)+instance HasBuiltins m => HasBuiltins (ListT m)+instance HasBuiltins m => HasBuiltins (MaybeT m)+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 (StateT s m) where-  getBuiltinThing b = lift $ getBuiltinThing b+deriving instance HasBuiltins m => HasBuiltins (BlockT m) -instance (HasBuiltins m, Monoid w) => HasBuiltins (WriterT w m) where-  getBuiltinThing b = lift $ getBuiltinThing b+instance MonadIO m => HasBuiltins (TCMT m) where+  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useTC stLocalBuiltins)+                      (Map.lookup b <$> useTC stImportedBuiltins)  -- If Agda is changed so that the type of a literal can belong to an -- inductive family (with at least one index), then the implementation@@ -62,24 +62,20 @@ litType   :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)   => Literal -> m Type-litType l = case l of-  LitNat _ n    -> do+litType = \case+  LitNat n    -> do     _ <- primZero     when (n > 0) $ void $ primSuc     el <$> primNat-  LitWord64 _ _ -> el <$> primWord64-  LitFloat _ _  -> el <$> primFloat-  LitChar _ _   -> el <$> primChar-  LitString _ _ -> el <$> primString-  LitQName _ _  -> el <$> primQName-  LitMeta _ _ _ -> el <$> primAgdaMeta+  LitWord64 _ -> el <$> primWord64+  LitFloat _  -> el <$> primFloat+  LitChar _   -> el <$> primChar+  LitString _ -> el <$> primString+  LitQName _  -> el <$> primQName+  LitMeta _ _ -> el <$> primAgdaMeta   where     el t = El (mkType 0) t -instance MonadIO m => HasBuiltins (TCMT m) where-  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useTC stLocalBuiltins)-                      (Map.lookup b <$> useTC stImportedBuiltins)- setBuiltinThings :: BuiltinThings PrimFun -> TCM () setBuiltinThings b = stLocalBuiltins `setTCLens` b @@ -124,7 +120,7 @@  getPrimitiveTerm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)                  => String -> m Term-getPrimitiveTerm x = (`Def` []) <$> primFunName <$> getPrimitive x+getPrimitiveTerm x = (`Def` []) . primFunName <$> getPrimitive x  getPrimitiveTerm' :: HasBuiltins m => String -> m (Maybe Term) getPrimitiveTerm' x = fmap (`Def` []) <$> getPrimitiveName' x@@ -141,20 +137,22 @@ -- the error message. getTerm :: (HasBuiltins m) => String -> String -> m Term getTerm use name = flip fromMaybeM (getTerm' name) $-  return $! (throwImpossible $ ImpMissingDefinitions [name] use)+  return $! throwImpossible (ImpMissingDefinitions [name] use)   -- | Rewrite a literal to constructor form if possible.-constructorForm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)-                => Term -> m Term-constructorForm v = constructorForm' primZero primSuc v+constructorForm :: HasBuiltins m => Term -> m Term+constructorForm v = do+  let pZero = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero+      pSuc  = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc+  constructorForm' pZero pSuc v  constructorForm' :: Applicative m => m Term -> m Term -> Term -> m Term constructorForm' pZero pSuc v =   case v of-    Lit (LitNat r n)+    Lit (LitNat n)       | n == 0    -> pZero-      | n > 0     -> (`apply1` Lit (LitNat r $ n - 1)) <$> pSuc+      | n > 0     -> (`apply1` Lit (LitNat $ n - 1)) <$> pSuc       | otherwise -> pure v     _ -> pure v @@ -165,7 +163,7 @@ primInteger, primIntegerPos, primIntegerNegSuc,     primFloat, primChar, primString, primUnit, primUnitUnit, primBool, primTrue, primFalse,     primSigma,-    primList, primNil, primCons, primIO, primNat, primSuc, primZero,+    primList, primNil, primCons, primIO, primNat, primSuc, primZero, primMaybe, primNothing, primJust,     primPath, primPathP, primInterval, primIZero, primIOne, primPartial, primPartialP,     primIMin, primIMax, primINeg,     primIsOne, primItIsOne, primIsOne1, primIsOne2, primIsOneEmpty,@@ -186,7 +184,8 @@     primEquality, primRefl,     primRewrite, -- Name of rewrite relation     primLevel, primLevelZero, primLevelSuc, primLevelMax,-    primSetOmega,+    primLockUniv,+    primSet, primProp, primSetOmega, primStrictSet, primSSetOmega,     primFromNat, primFromNeg, primFromString,     -- builtins for reflection:     primQName, primArgInfo, primArgArgInfo, primArg, primArgArg, primAbs, primAbsAbs, primAgdaTerm, primAgdaTermVar,@@ -195,11 +194,13 @@     primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartName,     primHiding, primHidden, primInstance, primVisible,     primRelevance, primRelevant, primIrrelevant,+    primQuantity, primQuantity0, primQuantityω,+    primModality, primModalityConstructor,     primAssoc, primAssocLeft, primAssocRight, primAssocNon,     primPrecedence, primPrecRelated, primPrecUnrelated,     primFixity, primFixityFixity,     primAgdaLiteral, primAgdaLitNat, primAgdaLitWord64, primAgdaLitFloat, primAgdaLitString, primAgdaLitChar, primAgdaLitQName, primAgdaLitMeta,-    primAgdaSort, primAgdaSortSet, primAgdaSortLit, primAgdaSortUnsupported,+    primAgdaSort, primAgdaSortSet, primAgdaSortLit, primAgdaSortProp, primAgdaSortPropLit, primAgdaSortInf, primAgdaSortUnsupported,     primAgdaDefinition, primAgdaDefinitionFunDef, primAgdaDefinitionDataDef, primAgdaDefinitionRecordDef,     primAgdaDefinitionPostulate, primAgdaDefinitionPrimitive, primAgdaDefinitionDataConstructor,     primAgdaClause, primAgdaClauseClause, primAgdaClauseAbsurd,@@ -213,11 +214,13 @@     primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,     primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDefineFun,     primAgdaTCMGetType, primAgdaTCMGetDefinition,-    primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm,+    primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm, primAgdaTCMQuoteOmegaTerm,     primAgdaTCMBlockOnMeta, primAgdaTCMCommit, primAgdaTCMIsMacro,-    primAgdaTCMWithNormalisation, primAgdaTCMDebugPrint,+    primAgdaTCMWithNormalisation, primAgdaTCMDebugPrint, primAgdaTCMWithReconsParams,+    primAgdaTCMOnlyReduceDefs, primAgdaTCMDontReduceDefs,     primAgdaTCMNoConstraints,-    primAgdaTCMRunSpeculative+    primAgdaTCMRunSpeculative,+    primAgdaTCMExec     :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term  primInteger                           = getBuiltin builtinInteger@@ -235,6 +238,9 @@ primList                              = getBuiltin builtinList primNil                               = getBuiltin builtinNil primCons                              = getBuiltin builtinCons+primMaybe                             = getBuiltin builtinMaybe+primNothing                           = getBuiltin builtinNothing+primJust                              = getBuiltin builtinJust primIO                                = getBuiltin builtinIO primId                                = getBuiltin builtinId primConId                             = getBuiltin builtinConId@@ -296,7 +302,12 @@ primLevelZero                         = getBuiltin builtinLevelZero primLevelSuc                          = getBuiltin builtinLevelSuc primLevelMax                          = getBuiltin builtinLevelMax+primSet                               = getBuiltin builtinSet+primProp                              = getBuiltin builtinProp primSetOmega                          = getBuiltin builtinSetOmega+primLockUniv                          = getPrimitiveTerm builtinLockUniv+primSSetOmega                         = getBuiltin builtinSSetOmega+primStrictSet                         = getBuiltin builtinStrictSet primFromNat                           = getBuiltin builtinFromNat primFromNeg                           = getBuiltin builtinFromNeg primFromString                        = getBuiltin builtinFromString@@ -313,6 +324,11 @@ primRelevance                         = getBuiltin builtinRelevance primRelevant                          = getBuiltin builtinRelevant primIrrelevant                        = getBuiltin builtinIrrelevant+primQuantity                          = getBuiltin builtinQuantity+primQuantity0                         = getBuiltin builtinQuantity0+primQuantityω                         = getBuiltin builtinQuantityω+primModality                          = getBuiltin builtinModality+primModalityConstructor               = getBuiltin builtinModalityConstructor primAssoc                             = getBuiltin builtinAssoc primAssocLeft                         = getBuiltin builtinAssocLeft primAssocRight                        = getBuiltin builtinAssocRight@@ -326,6 +342,9 @@ primArgArgInfo                        = getBuiltin builtinArgArgInfo primAgdaSortSet                       = getBuiltin builtinAgdaSortSet primAgdaSortLit                       = getBuiltin builtinAgdaSortLit+primAgdaSortProp                      = getBuiltin builtinAgdaSortProp+primAgdaSortPropLit                   = getBuiltin builtinAgdaSortPropLit+primAgdaSortInf                       = getBuiltin builtinAgdaSortInf primAgdaSortUnsupported               = getBuiltin builtinAgdaSortUnsupported primAgdaTerm                          = getBuiltin builtinAgdaTerm primAgdaTermVar                       = getBuiltin builtinAgdaTermVar@@ -388,14 +407,19 @@ primAgdaTCMGetType                    = getBuiltin builtinAgdaTCMGetType primAgdaTCMGetDefinition              = getBuiltin builtinAgdaTCMGetDefinition primAgdaTCMQuoteTerm                  = getBuiltin builtinAgdaTCMQuoteTerm+primAgdaTCMQuoteOmegaTerm             = getBuiltin builtinAgdaTCMQuoteOmegaTerm primAgdaTCMUnquoteTerm                = getBuiltin builtinAgdaTCMUnquoteTerm primAgdaTCMBlockOnMeta                = getBuiltin builtinAgdaTCMBlockOnMeta primAgdaTCMCommit                     = getBuiltin builtinAgdaTCMCommit primAgdaTCMIsMacro                    = getBuiltin builtinAgdaTCMIsMacro primAgdaTCMWithNormalisation          = getBuiltin builtinAgdaTCMWithNormalisation+primAgdaTCMWithReconsParams           = getBuiltin builtinAgdaTCMWithReconsParams primAgdaTCMDebugPrint                 = getBuiltin builtinAgdaTCMDebugPrint+primAgdaTCMOnlyReduceDefs             = getBuiltin builtinAgdaTCMOnlyReduceDefs+primAgdaTCMDontReduceDefs             = getBuiltin builtinAgdaTCMDontReduceDefs primAgdaTCMNoConstraints              = getBuiltin builtinAgdaTCMNoConstraints primAgdaTCMRunSpeculative             = getBuiltin builtinAgdaTCMRunSpeculative+primAgdaTCMExec                       = getBuiltin builtinAgdaTCMExec  -- | The coinductive primitives. @@ -421,7 +445,32 @@ coinductionKit :: TCM (Maybe CoinductionKit) coinductionKit = tryMaybe coinductionKit' +-- | Sort primitives. +data SortKit = SortKit+  { nameOfSet      :: QName+  , nameOfProp     :: QName+  , nameOfSSet     :: QName+  , nameOfSetOmega :: IsFibrant -> QName+  }++sortKit :: HasBuiltins m => m SortKit+sortKit = do+  Def set      _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSet+  Def prop     _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinProp+  Def setomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega+  Def sset     _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet+  Def ssetomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSSetOmega+  return $ SortKit+    { nameOfSet      = set+    , nameOfProp     = prop+    , nameOfSSet     = sset+    , nameOfSetOmega = \case+        IsFibrant -> setomega+        IsStrict  -> ssetomega+    }++ ------------------------------------------------------------------------ -- * Path equality ------------------------------------------------------------------------@@ -434,7 +483,8 @@   case lamV ty of             (_, Def path _) -> path             (_, Con nm _ _)   -> conName nm-            (_, _)          -> __IMPOSSIBLE__+            (_, Var 0 [Proj _ l]) -> l+            (_, t)          -> __IMPOSSIBLE__  getBuiltinName', getPrimitiveName' :: HasBuiltins m => String -> m (Maybe QName) getBuiltinName' n = fmap getPrimName <$> getBuiltin' n@@ -476,9 +526,9 @@ intervalUnview' = do   iz <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIZero -- should it be a type error instead?   io <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIOne-  imin <- (`Def` []) <$> fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primIMin"-  imax <- (`Def` []) <$> fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primIMax"-  ineg <- (`Def` []) <$> fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primINeg"+  imin <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primIMin"+  imax <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primIMax"+  ineg <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primINeg"   return $ \ v -> case v of              IZero -> iz              IOne  -> io@@ -588,6 +638,7 @@  equalityUnview :: EqualityView -> Type equalityUnview (OtherType t) = t+equalityUnview (IdiomType t) = t equalityUnview (EqualityType s equality l t lhs rhs) =   El s $ Def equality $ map Apply (l ++ [t, lhs, rhs])

src/full/Agda/TypeChecking/Monad/Builtin.hs-boot view

@@ -3,9 +3,9 @@  import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Identity ( IdentityT )  import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Class (MonadIO)  import Agda.TypeChecking.Monad.Base (TCMT, Builtin, PrimFun) @@ -14,7 +14,10 @@       , Fail.MonadFail m       ) => HasBuiltins m where   getBuiltinThing :: String -> m (Maybe (Builtin PrimFun))+  default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => String -> m (Maybe (Builtin PrimFun))+  getBuiltinThing = lift . getBuiltinThing +instance HasBuiltins m => HasBuiltins (IdentityT m) instance HasBuiltins m => HasBuiltins (ReaderT e m) instance HasBuiltins m => HasBuiltins (StateT s m)

src/full/Agda/TypeChecking/Monad/Caching.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-}  module Agda.TypeChecking.Monad.Caching   ( -- * Log reading/writing operations@@ -17,9 +16,6 @@   , restorePostScopeState   ) where --import qualified Data.Map as Map- import Agda.Syntax.Common  import Agda.Interaction.Options@@ -27,6 +23,7 @@ import Agda.TypeChecking.Monad.Base 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)@@ -35,11 +32,19 @@  -- | To be called before any write or restore calls. {-# SPECIALIZE cachingStarts :: TCM () #-}-cachingStarts :: (MonadTCState m, ReadTCState m) => m ()+cachingStarts :: (MonadDebug m, MonadTCState m, ReadTCState m) => m () cachingStarts = do     NameId _ m <- useTC stFreshNameId     stFreshNameId `setTCLens` NameId 1 m     stAreWeCaching `setTCLens` True+    validateCache m -- fixes issue #4835+    where+      validateCache m = (localCache readFromCachedLog) >>= \case+        Just (_ , s) -> do+          let NameId _ m' = stPostFreshNameId s+          when (m' /= m) cleanCachedLog+        _ -> do+          return ()  areWeCaching :: (ReadTCState m) => m Bool areWeCaching = useR stAreWeCaching@@ -65,7 +70,7 @@                   }     in  s{stPostScopeState = pss'}   where-    mergeIPMap lm sm = Map.mapWithKey (\k v -> maybe v (`mergeIP` v) (Map.lookup k lm)) sm+    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.     mergeIP li si = li { ipRange = ipRange si }

src/full/Agda/TypeChecking/Monad/Constraints.hs view

@@ -2,23 +2,23 @@ module Agda.TypeChecking.Monad.Constraints where  import Control.Arrow ((&&&))--+import Control.Monad.Except+import Control.Monad.Reader  import qualified Data.Foldable as Fold import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set+import Data.Semigroup ((<>)) +import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Debug  import Agda.Utils.Lens import Agda.Utils.Monad-import Agda.Utils.Except - solvingProblem :: MonadConstraint m => ProblemId -> m a -> m a solvingProblem pid = solvingProblems (Set.singleton pid) @@ -30,16 +30,13 @@         (reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was not solved.")       $ {- else -} do         reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was solved!"-        wakeConstraints (return . blockedOn pid . clValue . theConstraint)+        wakeConstraints (wakeIfBlockedOnProblem pid . constraintUnblocker)   return x-  where-    blockedOn pid (Guarded _ pid') = pid == pid'-    blockedOn _ _ = False  isProblemSolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool isProblemSolved pid =   and2M (not . Set.member pid <$> asksTC envActiveProblems)-        (all (not . Set.member pid . constraintProblems) <$> getAllConstraints)+        (not . any (Set.member pid . constraintProblems) <$> getAllConstraints)  getConstraintsForProblem :: ReadTCState m => ProblemId -> m Constraints getConstraintsForProblem pid = List.filter (Set.member pid . constraintProblems) <$> getAllConstraints@@ -112,7 +109,7 @@   return $ s^.stAwakeConstraints ++ s^.stSleepingConstraints  withConstraint :: MonadConstraint m => (Constraint -> m a) -> ProblemConstraint -> m a-withConstraint f (PConstr pids c) = do+withConstraint f (PConstr pids _ c) = do   -- We should preserve the problem stack and the isSolvingConstraint flag   (pids', isSolving) <- asksTC $ envActiveProblems &&& envSolvingConstraints   enterClosure c $ \c ->@@ -121,34 +118,33 @@  buildProblemConstraint   :: (MonadTCEnv m, ReadTCState m)-  => Set ProblemId -> Constraint -> m ProblemConstraint-buildProblemConstraint pids c = PConstr pids <$> buildClosure c+  => Set ProblemId -> Blocker -> Constraint -> m ProblemConstraint+buildProblemConstraint pids unblock c = PConstr pids unblock <$> buildClosure c  buildProblemConstraint_   :: (MonadTCEnv m, ReadTCState m)-  => Constraint -> m ProblemConstraint+  => Blocker -> Constraint -> m ProblemConstraint buildProblemConstraint_ = buildProblemConstraint Set.empty -buildConstraint :: Constraint -> TCM ProblemConstraint-buildConstraint c = flip buildProblemConstraint c =<< asksTC envActiveProblems+buildConstraint :: Blocker -> Constraint -> TCM ProblemConstraint+buildConstraint unblock c = do+  pids <- asksTC envActiveProblems+  buildProblemConstraint pids unblock c  -- | Monad service class containing methods for adding and solving --   constraints class ( MonadTCEnv m       , ReadTCState m       , MonadError TCErr m+      , MonadBlock m       , HasOptions m       , MonadDebug m       ) => MonadConstraint m where   -- | Unconditionally add the constraint.-  addConstraint :: Constraint -> m ()+  addConstraint :: Blocker -> Constraint -> m ()    -- | Add constraint as awake constraint.-  addAwakeConstraint :: Constraint -> m ()--  -- | `catchPatternErr handle m` runs m, handling pattern violations-  --    with `handle` (doesn't roll back the state)-  catchPatternErr :: m a -> m a -> m a+  addAwakeConstraint :: Blocker -> Constraint -> m ()    solveConstraint :: Constraint -> m () @@ -156,7 +152,7 @@   --   True solve constraints even if already 'isSolvingConstraints'.   solveSomeAwakeConstraints :: (ProblemConstraint -> Bool) -> Bool -> m () -  wakeConstraints :: (ProblemConstraint-> m Bool) -> m ()+  wakeConstraints :: (ProblemConstraint-> WakeUp) -> m ()    stealConstraints :: ProblemId -> m () @@ -164,38 +160,58 @@    modifySleepingConstraints  :: (Constraints -> Constraints) -> m () +instance MonadConstraint m => MonadConstraint (ReaderT e m) where+  addConstraint             = (lift .) . addConstraint+  addAwakeConstraint        = (lift .) . addAwakeConstraint+  solveConstraint           = lift . solveConstraint+  solveSomeAwakeConstraints = (lift .) . solveSomeAwakeConstraints+  stealConstraints          = lift . stealConstraints+  modifyAwakeConstraints    = lift . modifyAwakeConstraints+  modifySleepingConstraints = lift . modifySleepingConstraints+  wakeConstraints = lift . wakeConstraints++addAndUnblocker :: MonadBlock m => Blocker -> m a -> m a+addAndUnblocker u+  | u == alwaysUnblock = id+  | otherwise          = catchPatternErr $ \ u' -> patternViolation (u <> u')++addOrUnblocker :: MonadBlock m => Blocker -> m a -> m a+addOrUnblocker u+  | u == neverUnblock = id+  | otherwise         = catchPatternErr $ \ u' -> patternViolation (unblockOnEither u u')+ -- | Add new a constraint-addConstraint' :: Constraint -> TCM ()+addConstraint' :: Blocker -> Constraint -> TCM () addConstraint' = addConstraintTo stSleepingConstraints -addAwakeConstraint' :: Constraint -> TCM ()+addAwakeConstraint' :: Blocker -> Constraint -> TCM () addAwakeConstraint' = addConstraintTo stAwakeConstraints -addConstraintTo :: Lens' Constraints TCState -> Constraint -> TCM ()-addConstraintTo bucket c = do+addConstraintTo :: Lens' Constraints TCState -> Blocker -> Constraint -> TCM ()+addConstraintTo bucket unblock c = do     pc <- build     stDirty `setTCLens` True     bucket `modifyTCLens` (pc :)   where-    build | isBlocking c = buildConstraint c-          | otherwise    = buildProblemConstraint_ c+    build | isBlocking c = buildConstraint unblock c+          | otherwise    = buildProblemConstraint_ unblock c     isBlocking = \case       SortCmp{}        -> False       LevelCmp{}       -> False+      FindInstance{}   -> False+      HasBiggerSort{}  -> False+      HasPTSRule{}     -> False       ValueCmp{}       -> True       ValueCmpOnFace{} -> True       ElimCmp{}        -> True-      TelCmp{}         -> True-      Guarded c _      -> isBlocking c       UnBlock{}        -> True-      FindInstance{}   -> False       IsEmpty{}        -> True       CheckSizeLtSat{} -> True       CheckFunDef{}    -> True-      HasBiggerSort{}  -> False-      HasPTSRule{}     -> False       UnquoteTactic{}  -> True       CheckMetaInst{}  -> True+      CheckLockedVars{} -> True+      UsableAtModality{} -> True  -- | Start solving constraints nowSolvingConstraints :: MonadTCEnv m => m a -> m a@@ -206,7 +222,7 @@  -- | Add constraint if the action raises a pattern violation catchConstraint :: MonadConstraint m => Constraint -> m () -> m ()-catchConstraint c = catchPatternErr $ addConstraint c+catchConstraint c = catchPatternErr $ \ unblock -> addConstraint unblock c  --------------------------------------------------------------------------- -- * Lenses

src/full/Agda/TypeChecking/Monad/Context.hs view

@@ -1,10 +1,14 @@  module Agda.TypeChecking.Monad.Context where +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans.Maybe import Control.Monad.Writer+-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail)  import qualified Data.List as List@@ -16,7 +20,6 @@ import Agda.Syntax.Internal import Agda.Syntax.Position import Agda.Syntax.Scope.Base-import Agda.Syntax.Scope.Monad (getLocalVars, setLocalVars)  import Agda.TypeChecking.Free import Agda.TypeChecking.Monad.Base@@ -25,13 +28,13 @@ import Agda.TypeChecking.Monad.Open import Agda.TypeChecking.Monad.State -import Agda.Utils.Empty-import Agda.Utils.Except import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List ((!!!), downFrom) import Agda.Utils.ListT+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Pretty import Agda.Utils.Size@@ -80,7 +83,7 @@  -- | Delete the last @n@ bindings from the context. Any occurrences of -- these variables are replaced with the given @err@.-escapeContext :: MonadAddContext m => Empty -> Int -> m a -> m a+escapeContext :: MonadAddContext m => Impossible -> Int -> m a -> m a escapeContext err n = updateContext (strengthenS err n) $ drop n  -- * Manipulating checkpoints --@@ -161,51 +164,50 @@    withFreshName :: Range -> ArgName -> (Name -> m a) -> m a --- | Default implementation of addCtx in terms of updateContext-defaultAddCtx :: MonadAddContext m => Name -> Dom Type -> m a -> m a-defaultAddCtx x a ret = do-  q <- viewTC eQuantity-  let ce = (x,) <$> inverseApplyQuantity q a-  updateContext (raiseS 1) (ce :) ret+  default addCtx+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Name -> Dom Type -> m a -> m a+  addCtx x a = liftThrough $ addCtx x a -withFreshName_ :: (MonadAddContext m) => ArgName -> (Name -> m a) -> m a-withFreshName_ = withFreshName noRange+  default addLetBinding'+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Name -> Term -> Dom Type -> m a -> m a+  addLetBinding' x u a = liftThrough $ addLetBinding' x u a -instance MonadAddContext m => MonadAddContext (MaybeT m) where-  addCtx x a = MaybeT . addCtx x a . runMaybeT-  addLetBinding' x u a = MaybeT . addLetBinding' x u a . runMaybeT-  updateContext sub f = MaybeT . updateContext sub f . runMaybeT-  withFreshName r x = MaybeT . withFreshName r x . (runMaybeT .)+  default updateContext+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Substitution -> (Context -> Context) -> m a -> m a+  updateContext sub f = liftThrough $ updateContext sub f -instance MonadAddContext m => MonadAddContext (ExceptT e m) where-  addCtx x a = mkExceptT . addCtx x a . runExceptT-  addLetBinding' x u a = mkExceptT . addLetBinding' x u a . runExceptT-  updateContext sub f = mkExceptT . updateContext sub f . runExceptT-  withFreshName r x = mkExceptT . withFreshName r x . (runExceptT .)+  default withFreshName+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Range -> ArgName -> (Name -> m a) -> m a+  withFreshName r x cont = do+    st <- liftWith $ \ run -> do+      withFreshName r x $ run . cont+    restoreT $ return st -instance MonadAddContext m => MonadAddContext (ReaderT r m) where-  addCtx x a = ReaderT . (addCtx x a .) . runReaderT-  addLetBinding' x u a = ReaderT . (addLetBinding' x u a .) . runReaderT-  updateContext sub f = ReaderT . (updateContext sub f .) . runReaderT-  withFreshName r x ret = ReaderT $ \env -> withFreshName r x $ \n -> runReaderT (ret n) env+-- | 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) (((x,) <$> a) :) ret -instance (Monoid w, MonadAddContext m) => MonadAddContext (WriterT w m) where-  addCtx x a = WriterT . addCtx x a . runWriterT-  addLetBinding' x u a = WriterT . addLetBinding' x u a . runWriterT-  updateContext sub f = WriterT . updateContext sub f . runWriterT-  withFreshName r x = WriterT . withFreshName r x . (runWriterT .)+withFreshName_ :: (MonadAddContext m) => ArgName -> (Name -> m a) -> m a+withFreshName_ = withFreshName noRange -instance MonadAddContext m => MonadAddContext (StateT r m) where-  addCtx x a = StateT . (addCtx x a .) . runStateT-  addLetBinding' x u a = StateT . (addLetBinding' x u a .) . runStateT-  updateContext sub f = StateT . (updateContext sub f .) . runStateT-  withFreshName r x ret = StateT $ \s -> withFreshName r x $ \n -> runStateT (ret n) s+instance MonadAddContext m => MonadAddContext (ExceptT e m)+instance MonadAddContext m => MonadAddContext (IdentityT m)+instance MonadAddContext m => MonadAddContext (MaybeT m)+instance MonadAddContext m => MonadAddContext (ReaderT r m)+instance MonadAddContext m => MonadAddContext (StateT r m)+instance (Monoid w, MonadAddContext m) => MonadAddContext (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' x u a = liftListT $ addLetBinding' x u a-  updateContext sub f = liftListT $ updateContext sub f-  withFreshName r x ret = ListT $ withFreshName r x $ \n -> runListT (ret n)+  addCtx x a             = liftListT $ addCtx x a+  addLetBinding' x u a   = liftListT $ addLetBinding' x u a+  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@@ -289,9 +291,17 @@   addContext (xs, dom) = addContext (bindsToTel' id xs dom)   contextSize (xs, _) = length xs +instance AddContext (List1 Name, Dom Type) where+  addContext (xs, dom) = addContext (bindsToTel'1 id xs dom)+  contextSize (xs, _) = length xs+ instance AddContext ([WithHiding Name], Dom Type) where-  addContext ([]                 , dom) = id-  addContext (WithHiding h x : xs, dom) =+  addContext ([]    , dom) = id+  addContext (x : xs, dom) = addContext (x :| xs, dom)+  contextSize (xs, _) = length xs++instance AddContext (List1 (WithHiding Name), Dom Type) where+  addContext (WithHiding h x :| xs, dom) =     addContext (x , mapHiding (mappend h) dom) .     addContext (xs, raise 1 dom)   contextSize (xs, _) = length xs@@ -300,9 +310,17 @@   addContext (xs, t) = addContext ((map . fmap) unnamed xs :: [NamedArg Name], t)   contextSize (xs, _) = length xs +instance AddContext (List1 (Arg Name), Type) where+  addContext (xs, t) = addContext ((fmap . fmap) unnamed xs :: List1 (NamedArg Name), t)+  contextSize (xs, _) = length xs+ instance AddContext ([NamedArg Name], Type) where   addContext ([], _)     = id-  addContext (x : xs, t) =+  addContext (x : xs, t) = addContext (x :| xs, t)+  contextSize (xs, _) = length xs++instance AddContext (List1 (NamedArg Name), Type) where+  addContext (x :| xs, t) =     addContext (namedArg x, t <$ domFromNamedArgName x) .     addContext (xs, raise 1 t)   contextSize (xs, _) = length xs@@ -342,35 +360,35 @@   contextSize = size  -- | Go under an abstraction.  Do not extend context in case of 'NoAbs'.-{-# SPECIALIZE underAbstraction :: Subst t a => Dom Type -> Abs a -> (a -> TCM b) -> TCM b #-}-underAbstraction :: (Subst t a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b+{-# SPECIALIZE underAbstraction :: Subst a => Dom Type -> Abs a -> (a -> TCM b) -> TCM b #-}+underAbstraction :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b underAbstraction = underAbstraction' id -underAbstraction' :: (Subst t a, MonadAddContext m, AddContext (name, Dom Type)) =>+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  -- | Go under an abstraction, treating 'NoAbs' as 'Abs'.-underAbstractionAbs :: (Subst t a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b+underAbstractionAbs :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b underAbstractionAbs = underAbstractionAbs' id  underAbstractionAbs'-  :: (Subst t a, MonadAddContext m, AddContext (name, Dom Type))+  :: (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   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 t a => Abs a -> (a -> TCM b) -> TCM b #-}-underAbstraction_ :: (Subst t a, MonadAddContext m) => Abs a -> (a -> m b) -> m b+{-# SPECIALIZE underAbstraction_ :: Subst a => Abs a -> (a -> TCM b) -> TCM b #-}+underAbstraction_ :: (Subst a, MonadAddContext m) => Abs a -> (a -> m b) -> m b underAbstraction_ = underAbstraction __DUMMY_DOM__  -- | Map a monadic function on the thing under the abstraction, adding --   the abstracted variable to the context. mapAbstraction-  :: (Subst t a, Subst t' b, Free b, MonadAddContext m)+  :: (Subst a, Subst b, MonadAddContext m)   => Dom Type -> (a -> m b) -> Abs a -> m (Abs b) mapAbstraction dom f x = (x $>) <$> underAbstraction dom x f @@ -381,7 +399,7 @@  -- | Add a let bound variable {-# SPECIALIZE addLetBinding' :: Name -> Term -> Dom Type -> TCM a -> TCM a #-}-defaultAddLetBinding' :: MonadTCEnv m => Name -> Term -> Dom Type -> m a -> m a+defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Name -> Term -> Dom Type -> m a -> m a defaultAddLetBinding' x v t ret = do     vt <- makeOpen (v, t)     flip localTC ret $ \e -> e { envLetBindings = Map.insert x vt $ envLetBindings e }

src/full/Agda/TypeChecking/Monad/Context.hs-boot view

@@ -3,6 +3,8 @@  import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity ( IdentityT )  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -17,6 +19,30 @@   updateContext :: Substitution -> (Context -> Context) -> m a -> m a   withFreshName :: Range -> ArgName -> (Name -> m a) -> m a +  default addCtx+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Name -> Dom Type -> m a -> m a+  addCtx x a = liftThrough $ addCtx x a++  default addLetBinding'+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Name -> Term -> Dom Type -> m a -> m a+  addLetBinding' x u a = liftThrough $ addLetBinding' x u a++  default updateContext+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Substitution -> (Context -> Context) -> m a -> m a+  updateContext sub f = liftThrough $ updateContext sub f++  default withFreshName+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Range -> ArgName -> (Name -> m a) -> m a+  withFreshName r x cont = do+    st <- liftWith $ \ run -> do+      withFreshName r x $ run . cont+    restoreT $ return st++instance MonadAddContext m => MonadAddContext (IdentityT m) where instance MonadAddContext m => MonadAddContext (ReaderT r m) where instance MonadAddContext m => MonadAddContext (StateT r m) where

src/full/Agda/TypeChecking/Monad/Debug.hs view

@@ -4,18 +4,17 @@   , Verbosity, VerboseKey, VerboseLevel   ) where -import GHC.Stack (HasCallStack, freezeCallStack, callStack)- import qualified Control.Exception as E import qualified Control.DeepSeq as DeepSeq (force)+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough ) import Control.Monad.Trans.Maybe import Control.Monad.Trans.Identity import Control.Monad.Writer  import Data.Maybe-import Data.Monoid ( Monoid)  import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base@@ -23,7 +22,7 @@ import Agda.Interaction.Options import {-# SOURCE #-} Agda.Interaction.Response (Response(..)) -import Agda.Utils.Except+import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack ) import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.ListT@@ -36,32 +35,69 @@ import Agda.Utils.Impossible  class (Functor m, Applicative m, Monad m) => MonadDebug m where-  displayDebugMessage :: VerboseKey -> VerboseLevel -> String -> m ()-  displayDebugMessage k n s = traceDebugMessage k n s $ return () -  traceDebugMessage :: VerboseKey -> VerboseLevel -> String -> m a -> m a-  traceDebugMessage k n s cont = displayDebugMessage k n s >> cont-   formatDebugMessage :: VerboseKey -> VerboseLevel -> TCM Doc -> m String+  traceDebugMessage  :: VerboseKey -> VerboseLevel -> String -> m a -> m a -  getVerbosity :: m Verbosity+  -- | Print brackets around debug messages issued by a computation.+  verboseBracket     :: VerboseKey -> VerboseLevel -> String -> m a -> m a -  default getVerbosity :: HasOptions m => m Verbosity-  getVerbosity = optVerbose <$> pragmaOptions+  getVerbosity       :: m Verbosity -  isDebugPrinting :: m Bool+  -- | Check whether we are currently debug printing.+  isDebugPrinting    :: m Bool -  default isDebugPrinting :: MonadTCEnv m => m Bool-  isDebugPrinting = asksTC envIsDebugPrinting+  -- | Flag in a computation that we are currently debug printing.+  nowDebugPrinting   :: m a -> m a -  nowDebugPrinting :: m a -> m a+  -- default implementation of transformed debug monad -  default nowDebugPrinting :: MonadTCEnv m => m a -> m a-  nowDebugPrinting = locallyTC eIsDebugPrinting $ const True+  default formatDebugMessage+    :: (MonadTrans t, MonadDebug n, m ~ t n)+    => VerboseKey -> VerboseLevel -> TCM Doc -> m String+  formatDebugMessage k n d = lift $ formatDebugMessage k n d -  -- | Print brackets around debug messages issued by a computation.-  verboseBracket :: VerboseKey -> VerboseLevel -> String -> m a -> m a+  default traceDebugMessage+    :: (MonadTransControl t, MonadDebug n, m ~ t n)+    => VerboseKey -> VerboseLevel -> String -> m a -> m a+  traceDebugMessage k n s = liftThrough $ traceDebugMessage k n s +  default verboseBracket+    :: (MonadTransControl t, MonadDebug n, m ~ t n)+    => VerboseKey -> VerboseLevel -> String -> m a -> m a+  verboseBracket k n s = liftThrough $ verboseBracket k n s++  default getVerbosity+    :: (MonadTrans t, MonadDebug n, m ~ t n)+    => m Verbosity+  getVerbosity = lift getVerbosity++  default isDebugPrinting+    :: (MonadTrans t, MonadDebug n, m ~ t n)+    => m Bool+  isDebugPrinting = lift isDebugPrinting++  default nowDebugPrinting+    :: (MonadTransControl t, MonadDebug n, m ~ t n)+    => m a -> m a+  nowDebugPrinting = liftThrough nowDebugPrinting++-- Default implementations (working around the restriction to only+-- have one default signature).++defaultGetVerbosity :: HasOptions m => m Verbosity+defaultGetVerbosity = optVerbose <$> pragmaOptions++defaultIsDebugPrinting :: MonadTCEnv m => m Bool+defaultIsDebugPrinting = asksTC envIsDebugPrinting++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 k n s = traceDebugMessage k n s $ return ()+ -- | During printing, catch internal errors of kind 'Impossible' and print them. catchAndPrintImpossible   :: (CatchImpossible m, Monad m)@@ -72,7 +108,7 @@     , vcat $ map (nest 2 . text) $ lines $ show imposs     ]   where-  -- | Exception filter: Catch only the 'Impossible' exception during debug printing.+  -- Exception filter: Catch only the 'Impossible' exception during debug printing.   catchMe :: Impossible -> Maybe Impossible   catchMe = filterMaybe $ \case     Impossible{}            -> True@@ -81,12 +117,13 @@  instance MonadDebug TCM where -  displayDebugMessage k n s = do+  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     cb (Resp_RunningInfo n s)+    cont    formatDebugMessage k n d = catchAndPrintImpossible k n $ do     render <$> d `catchError` \ err -> do@@ -101,71 +138,31 @@    verboseBracket k n s = applyWhenVerboseS k n $ \ m -> do     openVerboseBracket k n s-    m `finally` closeVerboseBracket k n--instance MonadDebug m => MonadDebug (ExceptT e m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d = lift $ formatDebugMessage k n d-  getVerbosity = lift getVerbosity-  isDebugPrinting = lift isDebugPrinting-  nowDebugPrinting = mapExceptT nowDebugPrinting-  verboseBracket k n s = mapExceptT (verboseBracket k n s)--instance MonadDebug m => MonadDebug (ListT m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d = lift $ formatDebugMessage k n d-  getVerbosity = lift getVerbosity-  isDebugPrinting = lift isDebugPrinting-  nowDebugPrinting = liftListT nowDebugPrinting-  verboseBracket k n s = liftListT $ verboseBracket k n s--instance MonadDebug m => MonadDebug (MaybeT m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d = lift $ formatDebugMessage k n d-  getVerbosity = lift getVerbosity-  isDebugPrinting = lift isDebugPrinting-  nowDebugPrinting = mapMaybeT nowDebugPrinting-  verboseBracket k n s = MaybeT . verboseBracket k n s . runMaybeT+    (m <* closeVerboseBracket k n) `catchError` \ e -> do+      closeVerboseBracketException k n+      throwError e -instance MonadDebug m => MonadDebug (ReaderT r m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d = lift $ formatDebugMessage k n d-  getVerbosity = lift getVerbosity-  isDebugPrinting = lift isDebugPrinting-  nowDebugPrinting = mapReaderT nowDebugPrinting-  verboseBracket k n s = mapReaderT $ verboseBracket k n s+  getVerbosity     = defaultGetVerbosity+  isDebugPrinting  = defaultIsDebugPrinting+  nowDebugPrinting = defaultNowDebugPrinting -instance MonadDebug m => MonadDebug (StateT s m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d = lift $ formatDebugMessage k n d-  getVerbosity = lift getVerbosity-  isDebugPrinting = lift isDebugPrinting-  nowDebugPrinting = mapStateT nowDebugPrinting-  verboseBracket k n s = mapStateT $ verboseBracket k n s+-- MonadTrans default instances -instance (MonadDebug m, Monoid w) => MonadDebug (WriterT w m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d = lift $ formatDebugMessage k n d-  getVerbosity = lift getVerbosity-  isDebugPrinting = lift isDebugPrinting-  nowDebugPrinting = mapWriterT nowDebugPrinting-  verboseBracket k n s = mapWriterT $ verboseBracket k n s+deriving instance MonadDebug m => MonadDebug (BlockT m)  -- ghc <= 8.0, GeneralizedNewtypeDeriving+instance MonadDebug m => MonadDebug (ChangeT m)+instance MonadDebug m => MonadDebug (ExceptT e m)+instance MonadDebug m => MonadDebug (MaybeT m)+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 (IdentityT m) -instance MonadDebug m => MonadDebug (ChangeT m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d  = lift $ formatDebugMessage k n d-  getVerbosity              = lift $ getVerbosity-  isDebugPrinting           = lift $ isDebugPrinting-  nowDebugPrinting          = mapChangeT $ nowDebugPrinting-  verboseBracket k n s      = mapChangeT $ verboseBracket k n s+-- We are lacking MonadTransControl ListT -instance MonadDebug m => MonadDebug (IdentityT m) where-  displayDebugMessage k n s = lift $ displayDebugMessage k n s-  formatDebugMessage k n d  = lift $ formatDebugMessage k n d-  getVerbosity              = lift $ getVerbosity-  isDebugPrinting           = lift $ isDebugPrinting-  nowDebugPrinting          = mapIdentityT $ nowDebugPrinting-  verboseBracket k n s      = mapIdentityT $ verboseBracket k n s+instance MonadDebug m => MonadDebug (ListT m) where+  traceDebugMessage k n s = liftListT $ traceDebugMessage k n s+  verboseBracket    k n s = liftListT $ verboseBracket k n s+  nowDebugPrinting        = liftListT nowDebugPrinting  -- | Debug print some lines if the verbosity level for the given --   'VerboseKey' is at least 'VerboseLevel'.@@ -197,7 +194,7 @@ __IMPOSSIBLE_VERBOSE__ s = do { reportSLn "impossible" 10 s ; throwImpossible err }   where     -- Create the "Impossible" error using *our* caller as the call site.-    err = withFileAndLine' (freezeCallStack callStack) Impossible+    err = withCallerCallStack Impossible  -- | Conditionally render debug 'Doc' and print it. {-# SPECIALIZE reportSDoc :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM () #-}@@ -250,7 +247,10 @@ closeVerboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> m () closeVerboseBracket k n = displayDebugMessage k n "}\n" +closeVerboseBracketException :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()+closeVerboseBracketException k n = displayDebugMessage k n "} (exception)\n" + ------------------------------------------------------------------------ -- Verbosity @@ -273,7 +273,7 @@                  | otherwise = do     t <- getVerbosity     let ks = parseVerboseKey k-        m  = last $ 0 : Trie.lookupPath ks t+        m  = lastWithDefault 0 $ Trie.lookupPath ks t     return (n <= m)  -- | Check whether a certain verbosity level is activated (exact match).@@ -293,7 +293,7 @@ __CRASH_WHEN__ k n = whenExactVerbosity k n (throwImpossible err)   where     -- Create the "Unreachable" error using *our* caller as the call site.-    err = withFileAndLine' (freezeCallStack callStack) Unreachable+    err = withCallerCallStack Unreachable  -- | Run a computation if a certain verbosity level is activated. --

src/full/Agda/TypeChecking/Monad/Env.hs view

@@ -12,8 +12,6 @@ import Agda.TypeChecking.Monad.Base  import Agda.Utils.FileName-import Agda.Utils.Function-import Agda.Utils.SmallSet import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible@@ -57,20 +55,10 @@ getEnv :: TCM TCEnv getEnv = askTC --- | Increases the module nesting level by one in the given--- computation.-withIncreasedModuleNestingLevel :: TCM a -> TCM a-withIncreasedModuleNestingLevel =-  localTC $ \ e -> e { envModuleNestingLevel =-                       envModuleNestingLevel e + 1 }- -- | Set highlighting level withHighlightingLevel :: HighlightingLevel -> TCM a -> TCM a withHighlightingLevel h = localTC $ \ e -> e { envHighlightingLevel = h } -withoutOptionsChecking :: TCM a -> TCM a-withoutOptionsChecking = localTC $ \ e -> e { envCheckOptionConsistency = False }- -- | Restore setting for 'ExpandLast' to default. doExpandLast :: TCM a -> TCM a doExpandLast = localTC $ \ e -> e { envExpandLast = setExpand (envExpandLast e) }@@ -121,9 +109,10 @@ allowNonTerminatingReductions :: MonadTCEnv m => m a -> m a allowNonTerminatingReductions = putAllowedReductions reallyAllReductions --- | Allow all reductions when reducing types+-- | Allow all reductions when reducing types. Otherwise only allow+--   inlined functions to be unfolded. onlyReduceTypes :: MonadTCEnv m => m a -> m a-onlyReduceTypes = putAllowedReductions $ SmallSet.singleton TypeLevelReductions+onlyReduceTypes = putAllowedReductions $ SmallSet.fromList [TypeLevelReductions, InlineReductions]  -- | Update allowed reductions when working on types typeLevelReductions :: MonadTCEnv m => m a -> m a

src/full/Agda/TypeChecking/Monad/Imports.hs view

@@ -1,6 +1,25 @@ -module Agda.TypeChecking.Monad.Imports where+module Agda.TypeChecking.Monad.Imports+  ( addImport+  , addImportCycleCheck+  , checkForImportCycle+  , dropDecodedModule+  , getDecodedModule+  , getDecodedModules+  , getImportPath+  , getImports+  , getPrettyVisitedModules+  , getVisitedModule+  , getVisitedModules+  , isImported+  , setDecodedModules+  , setVisitedModules+  , storeDecodedModule+  , visitModule+  , withImportPath+  ) where +import Control.Arrow ( (***) ) import Control.Monad.State  @@ -11,7 +30,9 @@ import Agda.Syntax.Abstract.Name import qualified Agda.Syntax.Concrete.Name as C import Agda.TypeChecking.Monad.Base+ import Agda.Utils.List ( caseListM )+import Agda.Utils.Pretty   import Agda.Utils.Impossible@@ -40,21 +61,24 @@ setVisitedModules :: VisitedModules -> TCM () setVisitedModules ms = setTCLens stVisitedModules ms -getVisitedModules :: TCM VisitedModules+getVisitedModules :: ReadTCState m => m VisitedModules getVisitedModules = useTC stVisitedModules -isVisited :: C.TopLevelModuleName -> TCM Bool-isVisited x = Map.member x <$> useTC stVisitedModules+getPrettyVisitedModules :: ReadTCState m => m Doc+getPrettyVisitedModules = do+  visited <-  fmap (uncurry (<>) . (pretty *** (prettyCheckMode . miMode))) . Map.toList+          <$> getVisitedModules+  return $ hcat $ punctuate ", " visited+  where+  prettyCheckMode :: ModuleCheckMode -> Doc+  prettyCheckMode ModuleTypeChecked                  = ""+  prettyCheckMode ModuleScopeChecked                 = " (scope only)" -getVisitedModule :: C.TopLevelModuleName-                 -> TCM (Maybe ModuleInfo)+getVisitedModule :: ReadTCState m+                 => C.TopLevelModuleName+                 -> m (Maybe ModuleInfo) getVisitedModule x = Map.lookup x <$> useTC stVisitedModules -mapVisitedModule :: C.TopLevelModuleName-                 -> (ModuleInfo -> ModuleInfo)-                 -> TCM ()-mapVisitedModule x f = modifyTCLens stVisitedModules (Map.adjust f x)- getDecodedModules :: TCM DecodedModules getDecodedModules = stDecodedModules . stPersistentState <$> getTC @@ -62,15 +86,15 @@ setDecodedModules ms = modifyTC $ \s ->   s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } } -getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe Interface)+getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe ModuleInfo) getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> getTC -storeDecodedModule :: Interface -> TCM ()-storeDecodedModule i = modifyTC $ \s ->+storeDecodedModule :: ModuleInfo -> TCM ()+storeDecodedModule mi = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =-          Map.insert (toTopLevelModuleName $ iModuleName i) i $-            (stDecodedModules $ stPersistentState s)+          Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi $+            stDecodedModules (stPersistentState s)         }   }

src/full/Agda/TypeChecking/Monad/MetaVars.hs view

@@ -4,15 +4,18 @@  import Prelude hiding (null) +import Control.Monad.Except import Control.Monad.State+import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Reader import Control.Monad.Writer+-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail)  import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet-import qualified Data.Map as Map+import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Foldable as Fold@@ -34,8 +37,9 @@ import Agda.TypeChecking.Substitute import {-# SOURCE #-} Agda.TypeChecking.Telescope -import Agda.Utils.Except+import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor ((<.>))+import Agda.Utils.List (nubOn) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -176,7 +180,7 @@   return $ permute (takeP (length args) p) args  -- | Given a meta, return the type applied to the current context.-getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m)+getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m)                      => MetaId -> m Type getMetaTypeInContext m = do   mv@MetaVar{ mvJudgement = j } <- lookupMeta m@@ -215,10 +219,6 @@   isInstantiatedMeta (Plus n l) | n == 0 = isInstantiatedMeta l   isInstantiatedMeta _ = __IMPOSSIBLE__ -instance IsInstantiatedMeta LevelAtom where-  isInstantiatedMeta (MetaLevel x es) = isInstantiatedMeta x-  isInstantiatedMeta _ = __IMPOSSIBLE__- instance IsInstantiatedMeta a => IsInstantiatedMeta [a] where   isInstantiatedMeta = andM . map isInstantiatedMeta @@ -244,30 +244,37 @@ --   fact that blocked terms are represented by two meta variables. To find the --   second one we need to look up the meta listeners for the one in the --   UnBlock constraint.+--   This is used for the purpose of deciding if a metavariable is constrained or if it can be+--   generalized over (see Agda.TypeChecking.Generalize). constraintMetas :: Constraint -> TCM (Set MetaId)-constraintMetas c = metas c-  where+constraintMetas = \case     -- We don't use allMetas here since some constraints should not stop us from generalizing. For     -- instance CheckSizeLtSat (see #3694). We also have to check meta listeners to get metas of     -- UnBlock constraints.-    metas c = case c of-      ValueCmp _ t u v         -> return $ allMetas Set.singleton (t, u, v)-      ValueCmpOnFace _ p t u v -> return $ allMetas Set.singleton (p, t, u, v)-      ElimCmp _ _ t u es es'   -> return $ allMetas Set.singleton (t, u, es, es')+    -- #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 m t h g    -> return $ Set.fromList [x | Just x <- [m]] `Set.union` allMetas Set.singleton (t, h, g)-      Guarded c _              -> metas c-      TelCmp _ _ _ tel1 tel2   -> return $ allMetas Set.singleton (tel1, tel2)+      UnquoteTactic t h g      -> return $ allMetas Set.singleton (t, h, g)       SortCmp _ s1 s2          -> return $ allMetas Set.singleton (Sort s1, Sort s2)       UnBlock x                -> Set.insert x . Set.unions <$> (mapM listenerMetas =<< getMetaListeners x)-      FindInstance{}           -> return mempty  -- v Ignore these constraints+      FindInstance x _         ->+        -- #5093: We should not generalize over metas bound by instance constraints.+        -- We keep instance constraints even if the meta is solved, to check that it could indeed+        -- be filled by instance search. If it's solved, look in the solution.+        caseMaybeM (isInstantiatedMeta' x) (return $ Set.singleton x) $ return . allMetas Set.singleton       IsEmpty{}                -> return mempty       CheckFunDef{}            -> return mempty       CheckSizeLtSat{}         -> return mempty       HasBiggerSort{}          -> return mempty       HasPTSRule{}             -> return mempty       CheckMetaInst x          -> return mempty-+      CheckLockedVars a b c d  -> return $ allMetas Set.singleton (a, b, c, d)+      UsableAtModality{}       -> return mempty+  where     -- For blocked constant twin variables     listenerMetas EtaExpand{}           = return Set.empty     listenerMetas (CheckConstraint _ c) = constraintMetas (clValue $ theConstraint c)@@ -280,14 +287,18 @@   :: (MonadTCEnv m, ReadTCState m)   => RunMetaOccursCheck -> m MetaInfo createMetaInfo' b = do-  r   <- getCurrentRange-  cl  <- buildClosure r-  gen <- viewTC eGeneralizeMetas+  r        <- getCurrentRange+  cl       <- buildClosure r+  gen      <- viewTC eGeneralizeMetas+  modality <- viewTC eModality   return MetaInfo     { miClosRange       = cl+    , miModality        = modality     , miMetaOccursCheck = b     , miNameSuggestion  = ""-    , miGeneralizable   = hide $ defaultArg gen+    , miGeneralizable   = defaultArg gen+                          -- The ArgInfo is set to the right value in+                          -- the newArgsMetaCtx' function.     }  setValueMetaName :: MonadMetaSolver m => Term -> MetaNameSuggestion -> m ()@@ -309,8 +320,9 @@   updateMetaVar mi $ \ mvar ->     mvar { mvInfo = (mvInfo mvar) { miNameSuggestion = s }} -setMetaArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m ()-setMetaArgInfo m i = updateMetaVar m $ \ mv ->+-- | Change the ArgInfo that will be used when generalizing over this meta.+setMetaGeneralizableArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m ()+setMetaGeneralizableArgInfo m i = updateMetaVar m $ \ mv ->   mv { mvInfo = (mvInfo mv)         { miGeneralizable = setArgInfo i (miGeneralizable (mvInfo mv)) } } @@ -325,16 +337,21 @@  class (MonadTCEnv m, ReadTCState m) => MonadInteractionPoints m where   freshInteractionId :: m InteractionId-  modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> m ()--instance MonadInteractionPoints m => MonadInteractionPoints (ReaderT r m) where+  default freshInteractionId+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => m InteractionId   freshInteractionId = lift freshInteractionId-  modifyInteractionPoints = lift . modifyInteractionPoints -instance MonadInteractionPoints m => MonadInteractionPoints (StateT r m) where-  freshInteractionId = lift freshInteractionId+  modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> m ()+  default modifyInteractionPoints+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => (InteractionPoints -> InteractionPoints) -> m ()   modifyInteractionPoints = lift . modifyInteractionPoints +instance MonadInteractionPoints m => MonadInteractionPoints (IdentityT m)+instance MonadInteractionPoints m => MonadInteractionPoints (ReaderT r m)+instance MonadInteractionPoints m => MonadInteractionPoints (StateT s m)+ instance MonadInteractionPoints TCM where   freshInteractionId = fresh   modifyInteractionPoints f = stInteractionPoints `modifyTCLens` f@@ -363,7 +380,7 @@     Just i  -> return $ InteractionId i     Nothing -> freshInteractionId   let ip = InteractionPoint { ipRange = r, ipMeta = Nothing, ipSolved = False, ipClause = IPNoClause }-  case Map.insertLookupWithKey (\ key new old -> old) ii ip m of+  case BiMap.insertLookupWithKey (\ key new old -> old) ii ip m of     -- If the interaction point is already present, we keep the old ip.     -- However, it needs to be at the same range as the new one.     (Just ip0, _)@@ -374,16 +391,17 @@       return ii  -- | Find an interaction point by 'Range' by searching the whole map.+--   Issue 3000: Don't consider solved interaction points. -- --   O(n): linear in the number of registered interaction points.  findInteractionPoint_ :: Range -> InteractionPoints -> Maybe InteractionId findInteractionPoint_ r m = do   guard $ not $ null r-  listToMaybe $ mapMaybe sameRange $ Map.toList m+  listToMaybe $ mapMaybe sameRange $ BiMap.toList m   where     sameRange :: (InteractionId, InteractionPoint) -> Maybe InteractionId-    sameRange (ii, InteractionPoint r' _ _ _) | r == r' = Just ii+    sameRange (ii, InteractionPoint r' _ False _) | r == r' = Just ii     sameRange _ = Nothing  -- | Hook up meta variable to interaction point.@@ -395,36 +413,48 @@   m <- useR stInteractionPoints   let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi, ipSolved = False, ipClause = ipCl }   -- The interaction point needs to be present already, we just set the meta.-  case Map.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of+  case BiMap.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of     (Nothing, _) -> __IMPOSSIBLE__     (Just _, m') -> modifyInteractionPoints $ const m'  -- | Mark an interaction point as solved. removeInteractionPoint :: MonadInteractionPoints m => InteractionId -> m () removeInteractionPoint ii =-  modifyInteractionPoints $ Map.update (\ ip -> Just ip{ ipSolved = True }) ii+  modifyInteractionPoints $ BiMap.update (\ ip -> Just ip{ ipSolved = True }) ii  -- | Get a list of interaction ids. {-# SPECIALIZE getInteractionPoints :: TCM [InteractionId] #-} getInteractionPoints :: ReadTCState m => m [InteractionId]-getInteractionPoints = Map.keys <$> useR stInteractionPoints+getInteractionPoints = BiMap.keys <$> useR stInteractionPoints  -- | Get all metas that correspond to unsolved interaction ids. getInteractionMetas :: ReadTCState m => m [MetaId] getInteractionMetas =-  mapMaybe ipMeta . filter (not . ipSolved) . Map.elems <$> useR stInteractionPoints+  mapMaybe ipMeta . filter (not . ipSolved) . BiMap.elems <$> useR stInteractionPoints +getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]+getUniqueMetasRanges = fmap (nubOn id) . mapM getMetaRange++getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]+getUnsolvedMetas = do+  openMetas            <- getOpenMetas+  interactionMetas     <- getInteractionMetas+  getUniqueMetasRanges (openMetas List.\\ interactionMetas)++getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]+getUnsolvedInteractionMetas = getUniqueMetasRanges =<< getInteractionMetas+ -- | Get all metas that correspond to unsolved interaction ids. getInteractionIdsAndMetas :: ReadTCState m => m [(InteractionId,MetaId)] getInteractionIdsAndMetas =-  mapMaybe f . filter (not . ipSolved . snd) . Map.toList <$> useR stInteractionPoints+  mapMaybe f . filter (not . ipSolved . snd) . BiMap.toList <$> useR stInteractionPoints   where f (ii, ip) = (ii,) <$> ipMeta ip  -- | Does the meta variable correspond to an interaction point? -----   Time: @O(n)@ where @n@ is the number of interaction metas.+--   Time: @O(log n)@ where @n@ is the number of interaction metas. isInteractionMeta :: ReadTCState m => MetaId -> m (Maybe InteractionId)-isInteractionMeta x = lookup x . map swap <$> getInteractionIdsAndMetas+isInteractionMeta x = BiMap.invLookup x <$> useR stInteractionPoints  -- | Get the information associated to an interaction point. {-# SPECIALIZE lookupInteractionPoint :: InteractionId -> TCM InteractionPoint #-}@@ -432,7 +462,7 @@   :: (MonadFail m, ReadTCState m, MonadError TCErr m)   => InteractionId -> m InteractionPoint lookupInteractionPoint ii =-  fromMaybeM err $ Map.lookup ii <$> useR stInteractionPoints+  fromMaybeM err $ BiMap.lookup ii <$> useR stInteractionPoints   where     err  = fail $ "no such interaction point: " ++ show ii @@ -450,7 +480,7 @@ lookupInteractionMeta ii = lookupInteractionMeta_ ii <$> useR stInteractionPoints  lookupInteractionMeta_ :: InteractionId -> InteractionPoints -> Maybe MetaId-lookupInteractionMeta_ ii m = ipMeta =<< Map.lookup ii m+lookupInteractionMeta_ ii m = ipMeta =<< BiMap.lookup ii m  -- | Generate new meta variable. newMeta :: MonadMetaSolver m => Frozen -> MetaInfo -> MetaPriority -> Permutation -> Judgement a -> m MetaId@@ -619,12 +649,6 @@  instance UnFreezeMeta PlusLevel where   unfreezeMeta (Plus _ a)    = unfreezeMeta a--instance UnFreezeMeta LevelAtom where-  unfreezeMeta (MetaLevel x _)    = unfreezeMeta x-  unfreezeMeta (BlockedLevel _ t) = unfreezeMeta t-  unfreezeMeta (NeutralLevel _ t) = unfreezeMeta t-  unfreezeMeta (UnreducedLevel t) = unfreezeMeta t  instance UnFreezeMeta a => UnFreezeMeta [a] where   unfreezeMeta = mapM_ unfreezeMeta

src/full/Agda/TypeChecking/Monad/MetaVars.hs-boot view

@@ -3,6 +3,7 @@  import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Identity ( IdentityT )  import Agda.Syntax.Common (InteractionId) import Agda.TypeChecking.Monad.Base@@ -11,7 +12,18 @@   freshInteractionId :: m InteractionId   modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> m () +  default freshInteractionId+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => m InteractionId+  freshInteractionId = lift freshInteractionId++  default modifyInteractionPoints+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => (InteractionPoints -> InteractionPoints) -> m ()+  modifyInteractionPoints = lift . modifyInteractionPoints++instance MonadInteractionPoints m => MonadInteractionPoints (IdentityT m) instance MonadInteractionPoints m => MonadInteractionPoints (ReaderT r m)-instance MonadInteractionPoints m => MonadInteractionPoints (StateT r m)+instance MonadInteractionPoints m => MonadInteractionPoints (StateT s m)  instance MonadInteractionPoints TCM

src/full/Agda/TypeChecking/Monad/Mutual.hs view

@@ -5,7 +5,6 @@   -import Data.Functor ((<$>))  import qualified Data.Set as Set import qualified Data.Map as Map

src/full/Agda/TypeChecking/Monad/Open.hs view

@@ -6,32 +6,66 @@         , isClosed         ) where +import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set+ import Agda.Syntax.Internal import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.State (currentModuleNameHash)  import {-# SOURCE #-} Agda.TypeChecking.Monad.Context  import Agda.Utils.Lens+import Agda.Utils.Maybe  -- | Create an open term in the current context.-makeOpen :: MonadTCEnv m => a -> m (Open a)+makeOpen :: (ReadTCState m, MonadTCEnv m) => a -> m (Open a) makeOpen x = do-    cp <- viewTC eCurrentCheckpoint-    return $ OpenThing cp x+    cp  <- viewTC eCurrentCheckpoint+    env <- viewTC eCheckpoints+    m   <- currentModuleNameHash+    return $ OpenThing cp env m x  -- | Extract the value from an open term. The checkpoint at which it was --   created must be in scope.-getOpen :: (Subst Term a, MonadTCEnv m) => Open a -> m a-getOpen (OpenThing cp x) = do+getOpen :: (TermSubst a, MonadTCEnv m) => Open a -> m a+getOpen (OpenThing cp _ _ x) = do   sub <- checkpointSubstitution cp   return $ applySubst sub x --- | Extract the value from an open term. Returns `Nothing` if the checkpoint---   at which it was created is not in scope.-tryGetOpen :: (Subst Term a, MonadTCEnv m) => Open a -> m (Maybe a)-tryGetOpen (OpenThing cp x) = fmap (`applySubst` x) <$> viewTC (eCheckpoints . key cp)+-- | 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+--   substitution from the common ancestor to the checkpoint of the thing.+tryGetOpen :: (TermSubst a, ReadTCState m, MonadTCEnv m) => (Substitution -> a -> Maybe a) -> Open a -> m (Maybe a)+tryGetOpen extract open = do+  OpenThing cp env _ x <- restrict open -- Strip the env if from another module+  runMaybeT $ do+      (`applySubst` x) <$> (liftMaybe =<< viewTC (eCheckpoints . key cp))+    <|> do  -- Checkpoint no longer in scope+      curEnv <- lift $ viewTC eCheckpoints+      parent <- findParent env curEnv+      let Just subToOld = Map.lookup parent env+          Just subToCur = Map.lookup parent curEnv+      (applySubst subToCur) <$> liftMaybe (extract subToOld x)+  where+    -- If this comes from a different file, the checkpoints refer to checkpoints in that file and+    -- not in the current file. To avoid confusing them we set the checkpoint to -1 and only keep+    -- checkpoint 0 (which is shared between files) in the environment.+    restrict o@(OpenThing cp env m x) = do+      cur <- currentModuleNameHash+      if m == cur then return o+                  else return $ OpenThing (-1) (Map.filterWithKey (\ k _ -> k == 0) env) m x +    findParent m1 m2+      | Set.null keys = empty+      | otherwise     = return $ Set.findMax keys+      where+        keys = Set.intersection (Map.keysSet m1) (Map.keysSet m2)+ -- | An 'Open' is closed if it has checkpoint 0. isClosed :: Open a -> Bool-isClosed (OpenThing cp _) = cp == 0+isClosed (OpenThing cp _ _ _) = cp == 0

src/full/Agda/TypeChecking/Monad/Options.hs view

@@ -1,9 +1,10 @@  module Agda.TypeChecking.Monad.Options where -import Prelude hiding (mapM)--import Control.Monad.Reader hiding (mapM)+import Control.Arrow ( (&&&) )+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State import Control.Monad.Writer  import Data.Maybe@@ -20,9 +21,10 @@ import qualified Agda.Interaction.Options.Lenses as Lens import Agda.Interaction.Library import Agda.Utils.FileName+import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.Pretty-import Agda.Utils.Except+import Agda.Utils.WithDefault  import Agda.Utils.Impossible @@ -32,11 +34,9 @@ setPragmaOptions opts = do   stPragmaOptions `modifyTCLens` Lens.mapSafeMode (Lens.getSafeMode opts ||)   clo <- commandLineOptions-  let unsafe = unsafePragmaOptions opts---  when (Lens.getSafeMode clo && not (null unsafe)) $ warning $ SafeFlagPragma unsafe+  let unsafe = unsafePragmaOptions clo opts   when (Lens.getSafeMode opts && not (null unsafe)) $ warning $ SafeFlagPragma unsafe-  ok <- liftIO $ runOptM $ checkOpts (clo { optPragmaOptions = opts })-  case ok of+  runOptM (checkOpts clo{ optPragmaOptions = opts }) >>= \case     Left err   -> __IMPOSSIBLE__     Right opts -> do       stPragmaOptions `setTCLens` optPragmaOptions opts@@ -63,8 +63,7 @@   -> CommandLineOptions   -> TCM () setCommandLineOptions' root opts = do-  z <- liftIO $ runOptM $ checkOpts opts-  case z of+  runOptM (checkOpts opts) >>= \case     Left err   -> __IMPOSSIBLE__     Right opts -> do       incs <- case optAbsoluteIncludePaths opts of@@ -80,13 +79,29 @@  libToTCM :: LibM a -> TCM a libToTCM m = do-  (z, warns) <- liftIO $ runWriterT $ runExceptT m+  cachedConfs <- useTC stProjectConfigs+  cachedLibs  <- useTC stAgdaLibFiles +  ((z, warns), (cachedConfs', cachedLibs')) <- liftIO $+    (`runStateT` (cachedConfs, cachedLibs)) $ runWriterT $ runExceptT m++  modifyTCLens stProjectConfigs $ const cachedConfs'+  modifyTCLens stAgdaLibFiles   $ const cachedLibs'+   unless (null warns) $ warnings $ map LibraryWarning warns   case z of     Left s  -> typeError $ GenericDocError s     Right x -> return x +getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]+getAgdaLibFiles root = do+  useLibs <- optUseLibs <$> commandLineOptions+  if | useLibs   -> libToTCM $ mkLibM [] $ getAgdaLibFiles' root+     | otherwise -> return []++getLibraryOptions :: FilePath -> TCM [OptionsPragma]+getLibraryOptions root = map _libPragmas <$> getAgdaLibFiles root+ setLibraryPaths   :: AbsolutePath      -- ^ The base directory of relative paths.@@ -97,8 +112,7 @@  setLibraryIncludes :: CommandLineOptions -> TCM CommandLineOptions setLibraryIncludes o-  | or [ not $ optUseLibs o-       , optShowVersion o ] = pure o+  | not (optUseLibs o) = pure o   | otherwise = do     let libs = optLibraries o     installed <- libToTCM $ getInstalledLibraries (optOverrideLibrariesFile o)@@ -111,18 +125,28 @@   -> CommandLineOptions   -> TCM CommandLineOptions addDefaultLibraries root o-  | or [ not $ null $ optLibraries o-       , not $ optUseLibs o-       , optShowVersion o ] = pure o+  | not (null $ optLibraries o) || not (optUseLibs o) = pure o   | otherwise = do   (libs, incs) <- libToTCM $ getDefaultLibraries (filePath root) (optDefaultLibs o)   return o{ optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs } +-- This function is only called when an interactor exists+-- (i.e. when Agda actually does something).+addTrustedExecutables+  :: CommandLineOptions+  -> TCM CommandLineOptions+addTrustedExecutables o = do+  trustedExes <- libToTCM $ getTrustedExecutables+  -- Wen, 2020-06-03+  -- Replace the map wholesale instead of computing the union because this function+  -- should never be called more than once, and doing so either has the same result+  -- or is a security risk.+  return o{ optTrustedExecutables = trustedExes }+ setOptionsFromPragma :: OptionsPragma -> TCM () setOptionsFromPragma ps = do     opts <- commandLineOptions-    z    <- liftIO $ runOptM (parsePragmaOptions ps opts)-    case z of+    runOptM (parsePragmaOptions ps opts) >>= \case       Left err    -> typeError $ GenericError err       Right opts' -> setPragmaOptions opts' @@ -140,6 +164,18 @@ displayFormsEnabled :: MonadTCEnv m => m Bool displayFormsEnabled = asksTC envDisplayFormsEnabled +-- | Gets the include directories.+--+-- Precondition: 'optAbsoluteIncludePaths' must be nonempty (i.e.+-- 'setCommandLineOptions' must have run).++getIncludeDirs :: HasOptions m => m [AbsolutePath]+getIncludeDirs = do+  incs <- optAbsoluteIncludePaths <$> commandLineOptions+  case incs of+    [] -> __IMPOSSIBLE__+    _  -> return incs+ -- | Makes the given directories absolute and stores them as include -- directories. --@@ -161,10 +197,9 @@   incs <- return $  map (mkAbsolute . (filePath root </>)) incs    -- Andreas, 2013-10-30  Add default include dir-  libdir <- liftIO $ defaultLibDir       -- NB: This is an absolute file name, but       -- Agda.Utils.FilePath wants to check absoluteness anyway.-  let primdir = mkAbsolute $ libdir </> "prim"+  primdir <- liftIO $ mkAbsolute <$> getPrimitiveLibDir       -- 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...@@ -193,34 +228,22 @@   when (oldIncs /= incs) $ do     ho <- getInteractionOutputCallback     tcWarnings <- useTC stTCWarnings -- restore already generated warnings+    projectConfs <- useTC stProjectConfigs  -- restore cached project configs & .agda-lib+    agdaLibFiles <- useTC stAgdaLibFiles    -- files, since they use absolute paths     resetAllState     setTCLens stTCWarnings tcWarnings+    setTCLens stProjectConfigs projectConfs+    setTCLens stAgdaLibFiles agdaLibFiles     setInteractionOutputCallback ho    Lens.putAbsoluteIncludePaths incs -setInputFile :: FilePath -> TCM ()-setInputFile file =-    do  opts <- commandLineOptions-        setCommandLineOptions $-          opts { optInputFile = Just file }---- | Should only be run if 'hasInputFile'.-getInputFile :: TCM AbsolutePath-getInputFile = fromMaybeM __IMPOSSIBLE__ $-  getInputFile'---- | Return the 'optInputFile' as 'AbsolutePath', if any.-getInputFile' :: TCM (Maybe AbsolutePath)-getInputFile' = mapM (liftIO . absolute) =<< do-  optInputFile <$> commandLineOptions--hasInputFile :: HasOptions m => m Bool-hasInputFile = isJust <$> optInputFile <$> commandLineOptions- isPropEnabled :: HasOptions m => m Bool isPropEnabled = optProp <$> pragmaOptions +isTwoLevelEnabled :: HasOptions m => m Bool+isTwoLevelEnabled = collapseDefault . optTwoLevel <$> pragmaOptions+ {-# SPECIALIZE hasUniversePolymorphism :: TCM Bool #-} hasUniversePolymorphism :: HasOptions m => m Bool hasUniversePolymorphism = optUniversePolymorphism <$> pragmaOptions@@ -231,6 +254,9 @@ showIrrelevantArguments :: HasOptions m => m Bool showIrrelevantArguments = optShowIrrelevant <$> pragmaOptions +showIdentitySubstitutions :: HasOptions m => m Bool+showIdentitySubstitutions = optShowIdentitySubstitutions <$> pragmaOptions+ -- | Switch on printing of implicit and irrelevant arguments. --   E.g. for reification in with-function generation. --@@ -248,12 +274,6 @@ -- | Change 'PragmaOptions' for a computation and restore afterwards. withPragmaOptions :: ReadTCState m => (PragmaOptions -> PragmaOptions) -> m a -> m a withPragmaOptions = locallyTCState stPragmaOptions--ignoreInterfaces :: HasOptions m => m Bool-ignoreInterfaces = optIgnoreInterfaces <$> commandLineOptions--ignoreAllInterfaces :: HasOptions m => m Bool-ignoreAllInterfaces = optIgnoreAllInterfaces <$> commandLineOptions  positivityCheckEnabled :: HasOptions m => m Bool positivityCheckEnabled = not . optDisablePositivity <$> pragmaOptions

+ src/full/Agda/TypeChecking/Monad/Pure.hs view

@@ -0,0 +1,41 @@+-- | A typeclass collecting all 'pure' typechecking operations+-- | (i.e. ones that do not modify the typechecking state, throw or+-- | catch errors, or do IO other than debug printing).+++module Agda.TypeChecking.Monad.Pure where++import Control.Monad.Except ( ExceptT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Reader ( ReaderT )+import Control.Monad.State ( StateT )+import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Writer ( WriterT )++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Signature++import Agda.Utils.ListT++class+  ( HasBuiltins m+  , HasConstInfo m+  , MonadAddContext m+  , MonadDebug m+  , MonadReduce m+  , MonadTCEnv m+  , ReadTCState m+  ) => PureTCM m where++instance PureTCM TCM where+instance PureTCM m => PureTCM (BlockT m)+instance PureTCM m => PureTCM (ExceptT e m)+instance PureTCM m => PureTCM (IdentityT m)+instance PureTCM m => PureTCM (ListT m)+instance PureTCM m => PureTCM (MaybeT m)+instance PureTCM m => PureTCM (ReaderT r m)+instance (PureTCM m, Monoid w) => PureTCM (WriterT w m)+instance PureTCM m => PureTCM (StateT s m)

+ src/full/Agda/TypeChecking/Monad/Pure.hs-boot view

@@ -0,0 +1,29 @@++module Agda.TypeChecking.Monad.Pure where++import Control.Monad.Reader ( ReaderT )+import Control.Monad.State ( StateT )+import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Writer ( WriterT )++import Agda.TypeChecking.Monad.Base+import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin+import {-# SOURCE #-} Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature++class+  ( HasBuiltins m+  , HasConstInfo m+  , MonadAddContext m+  , MonadDebug m+  , MonadReduce m+  , MonadTCEnv m+  , ReadTCState m+  ) => PureTCM m where++instance PureTCM TCM where+instance PureTCM m => PureTCM (IdentityT m)+instance PureTCM m => PureTCM (ReaderT r m)+instance (PureTCM m, Monoid w) => PureTCM (WriterT w m)+instance PureTCM m => PureTCM (StateT s m)

src/full/Agda/TypeChecking/Monad/Signature.hs view

@@ -1,6 +1,4 @@-{-# LANGUAGE BangPatterns      #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies #-} -- for type equality ~  module Agda.TypeChecking.Monad.Signature where @@ -8,18 +6,22 @@  import qualified Control.Monad.Fail as Fail +import Control.Arrow (first, second)+import Control.Monad.Except import Control.Monad.State import Control.Monad.Reader-import Control.Monad.Writer+import Control.Monad.Writer hiding ((<>)) import Control.Monad.Trans.Maybe import Control.Monad.Trans.Identity +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.Maybe+import Data.Semigroup ((<>))  import Agda.Syntax.Abstract.Name import Agda.Syntax.Abstract (Ren, ScopeCopyInfo(..))@@ -27,7 +29,7 @@ import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Names import Agda.Syntax.Position-import Agda.Syntax.Treeless (Compiled(..), TTerm)+import Agda.Syntax.Treeless (Compiled(..), TTerm, ArgUsage)  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Builtin@@ -48,20 +50,22 @@ import {-# SOURCE #-} Agda.TypeChecking.Polarity import {-# SOURCE #-} Agda.TypeChecking.Pretty import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike+import {-# SOURCE #-} Agda.TypeChecking.Reduce  import {-# SOURCE #-} Agda.Compiler.Treeless.Erase--import {-# SOURCE #-} Agda.Main+import {-# SOURCE #-} Agda.Compiler.Builtin  import Agda.Utils.Either-import Agda.Utils.Except ( ExceptT ) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.ListT import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null+import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Update @@ -235,63 +239,91 @@ lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope lookupSection m = maybe EmptyTel (^. secTelescope) <$> getSection m --- Add display forms to all names @xn@ such that @x = x1 es1@, ... @xn-1 = xn esn@.+-- | Add display forms for a name @f@ copied by a module application. Essentially if @f@ can reduce to+--+-- @+-- λ xs → A.B.C.f vs+-- @+--+-- by unfolding module application copies (`defCopy`), then we add a display form+--+-- @+-- A.B.C.f vs ==> f xs+-- @ addDisplayForms :: QName -> TCM () addDisplayForms x = do-  def  <- getConstInfo x-  args <- drop (projectionArgs $ theDef def) <$> getContextArgs-  add args x x $ map Apply $ raise 1 args -- make room for the single match variable of the display form+  reportSDoc "tc.display.section" 20 $ "Computing display forms for" <+> pretty x+  def <- theDef <$> getConstInfo x+  let v = case def of+             Constructor{conSrcCon = h} -> Con h{ conName = x } ConOSystem []+             _                          -> Def x []++  -- Compute all unfoldings of x by repeatedly calling reduceDefCopy+  vs <- unfoldings x v+  reportSDoc "tc.display.section" 20 $ nest 2 $ vcat+    [ "unfoldings:" <?> vcat [ "-" <+> pretty v | v <- vs ] ]++  -- Turn unfoldings into display forms+  npars <- subtract (projectionArgs def) <$> getContextSize+  let dfs = catMaybes $ map (displayForm npars v) vs+  reportSDoc "tc.display.section" 20 $ nest 2 $ vcat+    [ "displayForms:" <?> vcat [ "-" <+> (pretty y <+> "-->" <?> pretty df) | (y, df) <- dfs ] ]++  -- and add them+  mapM_ (uncurry addDisplayForm) dfs   where-    add args top x es0 = do-      def <- getConstInfo x-      let cs = defClauses def-          isCopy = defCopy def-      case cs of-        [ cl ] -> do-          if not isCopy-            then noDispForm x "not a copy" else do-          if not $ all (isVar . namedArg) $ namedClausePats cl-            then noDispForm x "properly matching patterns" else do-          -- We have-          --    x ps = e-          -- and we're trying to generate a display form-          --    x es0 <-- e[es0/ps]-          -- Of course x es0 might be an over- or underapplication, hence the-          -- n/m arithmetic.-          let n          = size $ namedClausePats cl-              (es1, es2) = splitAt n es0-              m          = n - size es1-              vs1 = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1-              sub = parallelS $ reverse $ vs1 ++ replicate m (var 0)-              body = applySubst sub (compiledClauseBody cl) `applyE` es2-          case unSpine <$> body of-            Just (Def y es) -> do-              let df = Display m es $ DTerm $ Def top $ map Apply args-              reportSDoc "tc.display.section" 20 $ vcat-                [ "adding display form " <+> pretty y <+> " --> " <+> pretty top-                , text (show df)-                ]-              addDisplayForm y df-              add args top y es-            Just v          -> noDispForm x $ "not a def body, but " <+> pretty v-            Nothing         -> noDispForm x $ "bad body"-        [] | Constructor{ conSrcCon = h } <- theDef def -> do-              let y  = conName h-                  df = Display 0 [] $ DTerm $ Con (h {conName = top }) ConOSystem []-              reportSDoc "tc.display.section" 20 $ vcat-                [ "adding display form" <+> pretty y <+> "-->" <+> pretty top-                , text (show df)-                ]-              addDisplayForm y df-        [] -> noDispForm x "no clauses"-        (_:_:_) -> noDispForm x "many clauses" -    noDispForm x reason = reportSDoc "tc.display.section" 30 $-      "no display form from" <+> pretty x <+> "because" <+> reason+    -- To get display forms for projections we need to unSpine here.+    view :: Term -> ([Arg ArgName], Term)+    view = second unSpine . lamView -    isVar VarP{} = True-    isVar _      = False+    -- Given an unfolding `top = λ xs → y es` generate a display form+    -- `y es ==> top xs`. The first `npars` variables in `xs` are module parameters+    -- and should not be pattern variables, but matched literally.+    displayForm :: Nat -> Term -> Term -> Maybe (QName, DisplayForm)+    displayForm npars top v =+      case view v of+        (xs, Def y es)   -> (y,)         <$> mkDisplay xs es+        (xs, Con h i es) -> (conName h,) <$> mkDisplay xs es+        _ -> __IMPOSSIBLE__+      where+        mkDisplay xs es = Just (Display (n - npars) es $ DTerm $ top `apply` args)+          where+            n    = length xs+            args = zipWith (\ x i -> var i <$ x) xs (downFrom n) +    -- Unfold a single defCopy.+    unfoldOnce :: Term -> TCM (Reduced () Term)+    unfoldOnce v = case view v of+      (xs, Def f es)   -> (fmap . fmap) (unlamView xs) (reduceDefCopyTCM f es)+      (xs, Con c i es) -> (fmap . fmap) (unlamView xs) (reduceDefCopyTCM (conName c) es)+      _                -> pure $ NoReduction ()++    -- Compute all reduceDefCopy unfoldings of `x`. Stop when we hit a non-copy.+    unfoldings :: QName -> Term -> TCM [Term]+    unfoldings x v = unfoldOnce v >>= \ case+      NoReduction{}     -> return []+      YesReduction _ v' -> do+        let headSymbol = case snd $ view v' of+              Def y _   -> Just y+              Con y _ _ -> Just (conName y)+              _         -> Nothing+        case headSymbol of+          Nothing -> return []+          Just y | x == y -> do+            -- This should never happen, but if it does, getting an __IMPOSSIBLE__ is much better+            -- than looping.+            reportSDoc "impossible" 10 $ nest 2 $ vcat+              [ "reduceDefCopy said YesReduction but the head symbol is the same!?"+              , nest 2 $ "v  =" <+> pretty v+              , nest 2 $ "v' =" <+> pretty v'+              ]+            __IMPOSSIBLE__+          Just y -> do+            ifM (defCopy <$> getConstInfo y)+                ((v' :) <$> unfoldings y v')  -- another copy so keep going+                (return [v'])                 -- not a copy, we stop+ -- | Module application (followed by module parameter abstraction). applySection   :: ModuleName     -- ^ Name of new module defined by the module macro.@@ -308,19 +340,18 @@     -- and if a constructor is copied its datatype needs to be.     closeConstructors :: Ren QName -> TCM (Ren QName)     closeConstructors rd = do-        ds <- nubOn id . catMaybes <$> mapM (constructorData  . fst) rd-        cs <- nubOn id . concat    <$> mapM (dataConstructors . fst) rd-        new <- concat <$> mapM rename (ds ++ cs)+        ds <- nubOn id . catMaybes <$> traverse constructorData (Map.keys rd)+        cs <- nubOn id . concat    <$> traverse dataConstructors (Map.keys rd)+        new <- Map.unionsWith (<>) <$> traverse rename (ds ++ cs)         reportSDoc "tc.mod.apply.complete" 30 $           "also copying: " <+> pretty new-        return $ new ++ rd+        return $ Map.unionWith (<>) new rd       where         rename :: QName -> TCM (Ren QName)-        rename x =-          case lookup x rd of-            Nothing -> do y <- freshName_ (show $ qnameName x)-                          return [(x, qnameFromList [y])]-            Just{}  -> return []+        rename x+          | x `Map.member` rd = pure mempty+          | otherwise =+              Map.singleton x . pure . qnameFromList . singleton <$> freshName_ (prettyShow $ qnameName x)          constructorData :: QName -> TCM (Maybe QName)         constructorData x = do@@ -339,7 +370,7 @@ applySection' new ptel old ts ScopeCopyInfo{ renNames = rd, renModules = rm } = do   do     noCopyList <- catMaybes <$> mapM getName' constrainedPrims-    forM_ (map fst rd) $ \ q -> do+    for_ (Map.keys rd) $ \ q ->       when (q `elem` noCopyList) $ typeError (TriedToCopyConstrainedPrim q)    reportSDoc "tc.mod.apply" 10 $ vcat@@ -349,9 +380,9 @@     , "old  =" <+> pretty old     , "ts   =" <+> pretty ts     ]-  mapM_ (copyDef ts) rd-  mapM_ (copySec ts) rm-  computePolarity (map snd rd)+  _ <- Map.traverseWithKey (traverse . copyDef ts) rd+  _ <- Map.traverseWithKey (traverse . copySec ts) rm+  computePolarity (Map.elems rd >>= List1.toList)   where     -- Andreas, 2013-10-29     -- Here, if the name x is not imported, it persists as@@ -361,15 +392,18 @@     -- I guess it would make sense to mark non-imported names     -- as such (out-of-scope) and let splitting fail if it would     -- produce out-of-scope constructors.-    copyName x = fromMaybe x $ lookup x rd+    --+    -- Taking 'List1.head' because 'Module.Data.cons' and 'Module.cons' are+    -- equivalent valid names and either can be used.+    copyName x = maybe x List1.head (Map.lookup x rd)      argsToUse x = do       let m = commonParentModule old x       reportSDoc "tc.mod.apply" 80 $ "Common prefix: " <+> pretty m       size <$> lookupSection m -    copyDef :: Args -> (QName, QName) -> TCM ()-    copyDef ts (x, y) = do+    copyDef :: Args -> QName -> QName -> TCM ()+    copyDef ts x y = do       def <- getConstInfo x       np  <- argsToUse (qnameModule x)       -- Issue #3083: We need to use the hiding from the telescope of the@@ -450,7 +484,7 @@                 | size ts' < n || (size ts' == n && maybe True isVar0 (lastMaybe ts'))                 -> Just $ p { projIndex = n - size ts'                             , projLams  = projLams p `apply` ts'-                            , projProper= fmap copyName $ projProper p+                            , projProper= copyName <$> projProper p                             }               _ -> Nothing             def =@@ -498,6 +532,7 @@                             _ -> Def x $ map Apply ts'                         , clauseType      = Just $ defaultArg t                         , clauseCatchall  = False+                        , clauseExact       = Just True                         , clauseRecursive   = Just False -- definitely not recursive                         , clauseUnreachable = Just False -- definitely not unreachable                         , clauseEllipsis  = NoEllipsis@@ -523,9 +558,9 @@       tel = Ξ.(Θ.Δ)[ts]      calls-      1. copySec ts (Top.A.M, C.M)-      2. copySec ts (Top.B.N, C.N)-      3. copySec ts (Top.B.N.O, C.N.O)+      1. copySec ts Top.A.M C.M+      2. copySec ts Top.B.N C.N+      3. copySec ts Top.B.N.O C.N.O     with       old = Top.B @@ -538,16 +573,16 @@       new section C.M         tel =  Θ₂.Γ.Φ[ts']     -}-    copySec :: Args -> (ModuleName, ModuleName) -> TCM ()-    copySec ts (x, y) = do+    copySec :: Args -> ModuleName -> ModuleName -> TCM ()+    copySec ts x y = do       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       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 (List.intercalate " " (map (fst . unDom) $ telToList tel))  -- only names-      reportSDoc "tc.mod.apply" 80 $ "  sectionTel   = " <+> text (List.intercalate " " (map (fst . unDom) $ telToList ptel)) -- only names+      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  -- | Add a display form to a definition (could be in this or imported signature).@@ -576,10 +611,14 @@ chaseDisplayForms :: QName -> TCM (Set QName) chaseDisplayForms q = go Set.empty [q]   where+    go :: Set QName        -- Accumulator.+       -> [QName]          -- Work list.  TODO: make work set to avoid duplicate chasing?+       -> TCM (Set QName)     go used []       = pure used     go used (q : qs) = do       let rhs (Display _ _ e) = e   -- Only look at names in the right-hand side (#1870)-      ds <- (`Set.difference` used) . Set.unions . map (namesIn . rhs . dget)+      let notYetUsed x = if x `Set.member` used then Set.empty else Set.singleton x+      ds <- namesIn' notYetUsed . map (rhs . dget)             <$> (getDisplayForms q `catchError_` \ _ -> pure [])  -- might be a pattern synonym       go (Set.union ds used) (Set.toList ds ++ qs) @@ -663,7 +702,7 @@       Right d -> return d       Left (SigUnknown err) -> __IMPOSSIBLE_VERBOSE__ err       Left SigAbstract      -> __IMPOSSIBLE_VERBOSE__ $-        "Abstract, thus, not in scope: " ++ show q+        "Abstract, thus, not in scope: " ++ prettyShow q    -- | Version that reports exceptions:   getConstInfo' :: QName -> m (Either SigError Definition)@@ -686,8 +725,8 @@  {-# SPECIALIZE getConstInfo :: QName -> TCM Definition #-} -defaultGetRewriteRulesFor :: (Monad m) => m TCState -> QName -> m RewriteRules-defaultGetRewriteRulesFor getTCState q = do+defaultGetRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m RewriteRules+defaultGetRewriteRulesFor q = ifNotM (shouldReduceDef q) (return []) $ do   st <- getTCState   let sig = st^.stSignature       imp = st^.stImports@@ -700,7 +739,7 @@ getOriginalProjection q = projOrig . fromMaybe __IMPOSSIBLE__ <$> isProjection q  instance HasConstInfo (TCMT IO) where-  getRewriteRulesFor = defaultGetRewriteRulesFor getTC+  getRewriteRulesFor = defaultGetRewriteRulesFor   getConstInfo' q = do     st  <- getTC     env <- askTC@@ -717,9 +756,9 @@     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: " ++ show q ++ showQNameId q+        []  -> return $ Left $ SigUnknown $ "Unbound name: " ++ prettyShow q ++ showQNameId q         [d] -> mkAbs env d-        ds  -> __IMPOSSIBLE_VERBOSE__ $ "Ambiguous name: " ++ show q+        ds  -> __IMPOSSIBLE_VERBOSE__ $ "Ambiguous name: " ++ prettyShow q     where       mkAbs env d         | treatAbstractly' q' env =@@ -737,7 +776,9 @@             _             -> q            dropLastModule q@QName{ qnameModule = m } =-            q{ qnameModule = mnameFromList $ ifNull (mnameToList m) __IMPOSSIBLE__ init }+            q{ qnameModule = mnameFromList $+                 initWithDefault __IMPOSSIBLE__ $ mnameToList m+             }  -- HasConstInfo lifts through monad transformers -- (see default signatures in HasConstInfo class).@@ -750,6 +791,7 @@ 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 (BlockT m)  {-# INLINE getConInfo #-} getConInfo :: HasConstInfo m => ConHead -> m Definition@@ -766,7 +808,7 @@ getPolarity' CmpLeq q = getPolarity q -- composition with Covariant is identity  -- | Set the polarity of a definition.-setPolarity :: QName -> [Polarity] -> TCM ()+setPolarity :: (MonadTCState m, MonadDebug m) => QName -> [Polarity] -> m () setPolarity q pol = do   reportSDoc "tc.polarity.set" 20 $     "Setting polarity of" <+> pretty q <+> "to" <+> pretty pol <> "."@@ -786,27 +828,27 @@  -- | Sets the 'defArgOccurrences' for the given identifier (which -- should already exist in the signature).-setArgOccurrences :: QName -> [Occurrence] -> TCM ()+setArgOccurrences :: MonadTCState m => QName -> [Occurrence] -> m () setArgOccurrences d os = modifyArgOccurrences d $ const os -modifyArgOccurrences :: QName -> ([Occurrence] -> [Occurrence]) -> TCM ()+modifyArgOccurrences :: MonadTCState m => QName -> ([Occurrence] -> [Occurrence]) -> m () modifyArgOccurrences d f =   modifySignature $ updateDefinition d $ updateDefArgOccurrences f  setTreeless :: QName -> TTerm -> TCM () setTreeless q t =   modifyGlobalDefinition q $ updateTheDef $ \case-    fun@Function{} -> fun{ funTreeless = Just $ Compiled t [] }+    fun@Function{} -> fun{ funTreeless = Just $ Compiled t Nothing }     _ -> __IMPOSSIBLE__ -setCompiledArgUse :: QName -> [Bool] -> TCM ()+setCompiledArgUse :: QName -> [ArgUsage] -> TCM () setCompiledArgUse q use =   modifyGlobalDefinition q $ updateTheDef $ \case     fun@Function{} ->-      fun{ funTreeless = for (funTreeless fun) $ \ c -> c { cArgUsage = use } }+      fun{ funTreeless = funTreeless fun <&> \ c -> c { cArgUsage = Just use } }     _ -> __IMPOSSIBLE__ -getCompiled :: QName -> TCM (Maybe Compiled)+getCompiled :: HasConstInfo m => QName -> m (Maybe Compiled) getCompiled q = do   (theDef <$> getConstInfo q) <&> \case     Function{ funTreeless = t } -> t@@ -814,7 +856,7 @@  -- | Returns a list of length 'conArity'. --   If no erasure analysis has been performed yet, this will be a list of 'False's.-getErasedConArgs :: QName -> TCM [Bool]+getErasedConArgs :: HasConstInfo m => QName -> m [Bool] getErasedConArgs q = do   def <- getConstInfo q   case theDef def of@@ -829,11 +871,11 @@       | otherwise               -> __IMPOSSIBLE__     def -> def   -- no-op for non-constructors -getTreeless :: QName -> TCM (Maybe TTerm)+getTreeless :: HasConstInfo m => QName -> m (Maybe TTerm) getTreeless q = fmap cTreeless <$> getCompiled q -getCompiledArgUse :: QName -> TCM [Bool]-getCompiledArgUse q = maybe [] cArgUsage <$> getCompiled q+getCompiledArgUse :: HasConstInfo m => QName -> m (Maybe [ArgUsage])+getCompiledArgUse q = (cArgUsage =<<) <$> getCompiled q  -- | add data constructors to a datatype addDataCons :: QName -> [QName] -> TCM ()@@ -883,8 +925,8 @@ getDefModule f = mapRight modName <$> getConstInfo' f   where     modName def = case theDef def of-      Function{ funExtLam = Just (ExtLamInfo m _) } -> m-      _                                             -> qnameModule f+      Function{ funExtLam = Just (ExtLamInfo m _ _) } -> m+      _                                               -> qnameModule f  -- | 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@@ -979,9 +1021,9 @@ inFreshModuleIfFreeParams :: TCM a -> TCM a inFreshModuleIfFreeParams k = do   msub <- getModuleParameterSub =<< currentModule-  if msub == Nothing || msub == Just IdS then k else do+  if isNothing msub || msub == Just IdS then k else do     m  <- currentModule-    m' <- qualifyM m . mnameFromList . (:[]) <$>+    m' <- qualifyM m . mnameFromList1 . singleton <$>             freshName_ ("_" :: String)     addSection m'     withCurrentModule m' k@@ -1000,7 +1042,7 @@     m   <- currentModule     reportSDoc "tc.sig.inst" 30 $       "instDef in" <+> pretty m <> ":" <+> pretty (defName d) <+>-      text (unwords $ map show $ zipWith (<$) (reverse $ map (fst . unDom) ctx) vs)+      fsep (map pretty $ zipWith (<$) (reverse $ map (fst . unDom) ctx) vs)   return $ d `apply` vs  instantiateRewriteRule :: (Functor m, HasConstInfo m, HasOptions m,@@ -1031,7 +1073,7 @@                , theDef = def                }   where-    makeAbs Axiom         = Just Axiom+    makeAbs d@Axiom{}            = Just d     makeAbs d@DataOrRecSig{}     = Just d     makeAbs d@GeneralizableVar{} = Just d     makeAbs d@Datatype {} = Just $ AbstractDefn d@@ -1043,6 +1085,7 @@     -- to see whether the abstract thing is a record type or not.     makeAbs d@Record{}    = Just $ AbstractDefn d     makeAbs Primitive{}   = __IMPOSSIBLE__+    makeAbs PrimitiveSort{} = __IMPOSSIBLE__     makeAbs AbstractDefn{}= __IMPOSSIBLE__  -- | Enter abstract mode. Abstract definition in the current module are transparent.@@ -1125,6 +1168,7 @@     Record     {recPars = _} -> 0  -- not dropped     Constructor{conPars = n} -> n     Primitive{}              -> 0+    PrimitiveSort{}          -> 0     AbstractDefn{}           -> __IMPOSSIBLE__  -- | Is it the name of a record projection?@@ -1151,7 +1195,7 @@ --   (projection applied to argument). isProperProjection :: Defn -> Bool isProperProjection d = caseMaybe (isProjection_ d) False $ \ isP ->-  if projIndex isP <= 0 then False else isJust $ projProper isP+  (projIndex isP > 0) && isJust (projProper isP)  -- | Number of dropped initial arguments of a projection(-like) function. projectionArgs :: Defn -> Int

src/full/Agda/TypeChecking/Monad/Signature.hs-boot view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-} -- for type equality ~  module Agda.TypeChecking.Monad.Signature where

src/full/Agda/TypeChecking/Monad/SizedTypes.hs view

@@ -5,6 +5,8 @@  module Agda.TypeChecking.Monad.SizedTypes where +import Control.Monad.Except+ import qualified Data.Foldable as Fold import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty@@ -17,8 +19,8 @@ import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Substitute -import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad@@ -155,9 +157,7 @@             | n == 0    = return v             | otherwise = do   Def suc [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeSuc-  return $ case iterate (sizeSuc_ suc) v !!! n of-             Nothing -> __IMPOSSIBLE__-             Just t  -> t+  return $ fromMaybe __IMPOSSIBLE__ (iterate (sizeSuc_ suc) v !!! n)  sizeSuc_ :: QName -> Term -> Term sizeSuc_ suc v = Def suc [Apply $ defaultArg v]@@ -180,22 +180,44 @@ data SizeView = SizeInf | SizeSuc Term | OtherSize Term  -- | Expects argument to be 'reduce'd.-sizeView :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m)          => Term -> m SizeView sizeView v = do-  Def inf [] <- primSizeInf-  Def suc [] <- primSizeSuc+  Def inf [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeInf+  Def suc [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeSuc   case v of     Def x []        | x == inf -> return SizeInf     Def x [Apply u] | x == suc -> return $ SizeSuc (unArg u)     _                          -> return $ OtherSize v +-- | A de Bruijn index under some projections.++data ProjectedVar = ProjectedVar+  { pvIndex :: Int+  , prProjs :: [(ProjOrigin, QName)]+  }+  deriving (Show)++-- | Ignore 'ProjOrigin' in equality test.++instance Eq ProjectedVar where+  ProjectedVar i prjs == ProjectedVar i' prjs' =+    i == i' && map snd prjs == map snd prjs'++viewProjectedVar :: Term -> Maybe ProjectedVar+viewProjectedVar = \case+  Var i es -> ProjectedVar i <$> mapM isProjElim es+  _ -> Nothing++unviewProjectedVar :: ProjectedVar -> Term+unviewProjectedVar (ProjectedVar i prjs) = Var i $ map (uncurry Proj) prjs+ type Offset = Nat  -- | A deep view on sizes. data DeepSizeView   = DSizeInf-  | DSizeVar Nat Offset+  | DSizeVar ProjectedVar Offset   | DSizeMeta MetaId Elims Offset   | DOtherSize Term   deriving (Show)@@ -203,7 +225,7 @@ instance Pretty DeepSizeView where   pretty = \case     DSizeInf        -> "∞"-    DSizeVar n o     -> text ("@" ++ show n) <+> "+" <+> pretty o+    DSizeVar pv o    -> pretty (unviewProjectedVar pv) <+> "+" <+> pretty o     DSizeMeta x es o -> pretty (MetaV x es) <+> "+" <+> pretty o     DOtherSize t     -> pretty t @@ -223,7 +245,7 @@   _ -> NotComparable  sizeViewSuc_ :: QName -> DeepSizeView -> DeepSizeView-sizeViewSuc_ suc v = case v of+sizeViewSuc_ suc = \case   DSizeInf         -> DSizeInf   DSizeVar i n     -> DSizeVar i (n + 1)   DSizeMeta x vs n -> DSizeMeta x vs (n + 1)@@ -231,8 +253,8 @@  -- | @sizeViewPred k v@ decrements @v@ by @k@ (must be possible!). sizeViewPred :: Nat -> DeepSizeView -> DeepSizeView-sizeViewPred 0 v = v-sizeViewPred k v = case v of+sizeViewPred 0 = id+sizeViewPred k = \case   DSizeInf -> DSizeInf   DSizeVar  i    n | n >= k -> DSizeVar  i    (n - k)   DSizeMeta x vs n | n >= k -> DSizeMeta x vs (n - k)@@ -240,7 +262,7 @@  -- | @sizeViewOffset v@ returns the number of successors or Nothing when infty. sizeViewOffset :: DeepSizeView -> Maybe Offset-sizeViewOffset v = case v of+sizeViewOffset = \case   DSizeInf         -> Nothing   DSizeVar i n     -> Just n   DSizeMeta x vs n -> Just n@@ -263,9 +285,9 @@  unDeepSizeView :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)                => DeepSizeView -> m Term-unDeepSizeView v = case v of+unDeepSizeView = \case   DSizeInf         -> primSizeInf-  DSizeVar i     n -> sizeSuc n $ var i+  DSizeVar pv    n -> sizeSuc n $ unviewProjectedVar pv   DSizeMeta x us n -> sizeSuc n $ MetaV x us   DOtherSize u     -> return u @@ -298,7 +320,7 @@ sizeViewComparableWithMax :: DeepSizeView -> SizeMaxView -> SizeViewComparable SizeMaxView' sizeViewComparableWithMax v (w :| ws) =   case (ws, sizeViewComparable v w) of-    (w':ws', NotComparable) -> fmap (w:) $ sizeViewComparableWithMax v (w' :| ws')+    (w':ws', NotComparable) -> (w:) <$> sizeViewComparableWithMax v (w' :| ws')     (ws    , r)             -> fmap (const ws) r

src/full/Agda/TypeChecking/Monad/State.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- -- | Lenses for 'TCState' and more.  module Agda.TypeChecking.Monad.State where@@ -8,18 +6,16 @@ import qualified Control.Exception as E  import Control.Monad.State (void)-import Control.Monad.Trans (liftIO)+import Control.Monad.Trans (MonadIO, liftIO)  import Data.Maybe  import qualified Data.Map as Map -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap-import Data.Traversable (traverse)  import Agda.Benchmarking @@ -228,10 +224,10 @@  -- ** Lens for 'stSignature' and 'stImports' -modifySignature :: (Signature -> Signature) -> TCM ()+modifySignature :: MonadTCState m => (Signature -> Signature) -> m () modifySignature f = stSignature `modifyTCLens` f -modifyImportedSignature :: (Signature -> Signature) -> TCM ()+modifyImportedSignature :: MonadTCState m => (Signature -> Signature) -> m () modifyImportedSignature f = stImports `modifyTCLens` f  getSignature :: ReadTCState m => m Signature@@ -241,16 +237,16 @@ --   definitions (during type checking) will not persist outside the current --   module. This function is currently used to update the compiled --   representation of a function during compilation.-modifyGlobalDefinition :: QName -> (Definition -> Definition) -> TCM ()+modifyGlobalDefinition :: MonadTCState m => QName -> (Definition -> Definition) -> m () modifyGlobalDefinition q f = do   modifySignature         $ updateDefinition q f   modifyImportedSignature $ updateDefinition q f -setSignature :: Signature -> TCM ()+setSignature :: MonadTCState m => Signature -> m () setSignature sig = modifySignature $ const sig  -- | Run some computation in a different signature, restore original signature.-withSignature :: Signature -> TCM a -> TCM a+withSignature :: (ReadTCState m, MonadTCState m) => Signature -> m a -> m a withSignature sig m = do   sig0 <- getSignature   setSignature sig@@ -261,8 +257,8 @@ -- ** 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)+    over sigRewriteRules (HMap.insertWith mappend f rews)+  . updateDefinition f (updateTheDef setNotInjective . setCopatternLHS)   . (setMatchableSymbols f matchables)     where       setNotInjective def@Function{} = def { funInv = NotInjective }@@ -275,7 +271,7 @@  setMatchableSymbols :: QName -> [QName] -> Signature -> Signature setMatchableSymbols f matchables =-  foldr (.) id $ map (\g -> updateDefinition g $ setMatchable) matchables+  foldr ((.) . (\g -> updateDefinition g setMatchable)) id matchables     where       setMatchable def = def { defMatchable = Set.insert f $ defMatchable def } @@ -337,7 +333,7 @@ -- implementation of 'setTopLevelModule' should be changed.  setTopLevelModule :: C.QName -> TCM ()-setTopLevelModule x = stFreshNameId `setTCLens` NameId 0 (hashString $ prettyShow x)+setTopLevelModule x = stFreshNameId `setTCLens` NameId 0 (ModuleNameHash $ hashString $ prettyShow x)  -- | Use a different top-level module for a computation. Used when generating --   names for imported modules.@@ -349,6 +345,11 @@   stFreshNameId `setTCLens` next   return y +currentModuleNameHash :: ReadTCState m => m ModuleNameHash+currentModuleNameHash = do+  NameId _ h <- useTC stFreshNameId+  return h+ --------------------------------------------------------------------------- -- * Foreign code ---------------------------------------------------------------------------@@ -362,7 +363,7 @@ -- * Interaction output callback --------------------------------------------------------------------------- -getInteractionOutputCallback :: TCM InteractionOutputCallback+getInteractionOutputCallback :: ReadTCState m => m InteractionOutputCallback getInteractionOutputCallback   = getsTC $ stInteractionOutputCallback . stPersistentState

src/full/Agda/TypeChecking/Monad/Statistics.hs view

@@ -1,8 +1,5 @@ -- | Collect statistics. -{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE TypeFamilies      #-} -- for type equality- module Agda.TypeChecking.Monad.Statistics     ( MonadStatistics(..), tick, tickN, tickMax, getStatistics, modifyStatistics, printStatistics     ) where@@ -12,7 +9,6 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer-import Control.Monad.Trans import Control.Monad.Trans.Maybe  import qualified Data.Map as Map

src/full/Agda/TypeChecking/Monad/Trace.hs view

@@ -3,7 +3,11 @@  import Prelude hiding (null) +import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Identity+import Control.Monad.Writer  import qualified Data.Set as Set @@ -43,6 +47,8 @@     CheckClause{}             -> True     CheckLHS{}                -> True     CheckPattern{}            -> True+    CheckPatternLinearityType{}  -> True+    CheckPatternLinearityValue{} -> True     CheckLetBinding{}         -> True     InferExpr{}               -> True     CheckExprCall{}           -> True@@ -70,121 +76,154 @@     CheckProjection{}         -> True     ModuleContents{}          -> True -traceCallM :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => tcm Call -> tcm a -> tcm a-traceCallM call m = flip traceCall m =<< call+class (MonadTCEnv m, ReadTCState m) => MonadTrace m where --- | Reset 'envCall' to previous value in the continuation.------ Caveat: if the last 'traceCall' did not set an 'interestingCall',--- for example, only set the 'Range' with 'SetRange',--- we will revert to the last interesting call.+  -- | Record a function call in the trace.+  traceCall :: Call -> m a -> m a+  traceCall call m = do+    cl <- buildClosure call+    traceClosureCall cl m -traceCallCPS :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm)-  => Call-  -> ((a -> tcm b) -> tcm b)-  -> ((a -> tcm b) -> tcm b)-traceCallCPS call k ret = do-  mcall <- asksTC envCall-  traceCall call $ k $ \ a -> do-    maybe id traceClosureCall mcall $ ret a+  traceCallM :: m Call -> m a -> m a+  traceCallM call m = flip traceCall m =<< call --- | Record a function call in the trace.+  -- | Reset 'envCall' to previous value in the continuation.+  --+  -- Caveat: if the last 'traceCall' did not set an 'interestingCall',+  -- for example, only set the 'Range' with 'SetRange',+  -- we will revert to the last interesting call.+  traceCallCPS :: Call -> ((a -> m b) -> m b) -> ((a -> m b) -> m b)+  traceCallCPS call k ret = do+    mcall <- asksTC envCall+    traceCall call $ k $ \ a -> do+      maybe id traceClosureCall mcall $ ret a --- RULE left-hand side too complicated to desugar--- {-# SPECIALIZE traceCall :: Call -> TCM a -> TCM a #-}-traceCall :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Call -> tcm a -> tcm a-traceCall call m = do-  cl <- liftTCM $ buildClosure call-  traceClosureCall cl m+  traceClosureCall :: Closure Call -> m a -> m a -traceClosureCall :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) => Closure Call -> tcm a -> tcm a-traceClosureCall cl m = do+  -- | Lispify and print the given highlighting information.+  printHighlightingInfo :: RemoveTokenBasedHighlighting -> HighlightingInfo -> m () -  -- Andreas, 2016-09-13 issue #2177-  -- Since the fix of #2092 we may report an error outside the current file.-  -- (For instance, if we import a module which then happens to have the-  -- wrong name.)-  -- Thus, we no longer crash, but just report the alien range.-  -- -- Andreas, 2015-02-09 Make sure we do not set a range-  -- -- outside the current file-  verboseS "check.ranges" 90 $-    Strict.whenJust (rangeFile callRange) $ \f -> do-      currentFile <- asksTC envCurrentPath-      when (currentFile /= Just f) $ do-        reportSLn "check.ranges" 90 $-          prettyShow call ++-          " is setting the current range to " ++ show callRange ++-          " which is outside of the current file " ++ show currentFile+  default printHighlightingInfo+    :: (MonadTrans t, MonadTrace n, t n ~ m)+    => RemoveTokenBasedHighlighting -> HighlightingInfo -> m ()+  printHighlightingInfo r i = lift $ printHighlightingInfo r i -  -- 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+instance MonadTrace m => MonadTrace (IdentityT m) where+  traceClosureCall c f = IdentityT $ traceClosureCall c $ runIdentityT f++instance MonadTrace m => MonadTrace (ReaderT r m) where+  traceClosureCall c f = ReaderT $ \r -> traceClosureCall c $ runReaderT f r++instance MonadTrace m => MonadTrace (StateT s m) where+  traceClosureCall c f = StateT (traceClosureCall c . runStateT f)++instance (MonadTrace m, Monoid w) => MonadTrace (WriterT w m) where+  traceClosureCall c f = WriterT $ traceClosureCall c $ runWriterT f++instance MonadTrace m => MonadTrace (ExceptT e m) where+  traceClosureCall c f = ExceptT $ traceClosureCall c $ runExceptT f++instance MonadTrace TCM where+  traceClosureCall cl m = do+    -- Andreas, 2016-09-13 issue #2177+    -- Since the fix of #2092 we may report an error outside the current file.+    -- (For instance, if we import a module which then happens to have the+    -- wrong name.)+    -- Thus, we no longer crash, but just report the alien range.+    -- -- Andreas, 2015-02-09 Make sure we do not set a range+    -- -- outside the current file+    verboseS "check.ranges" 90 $+      Strict.whenJust (rangeFile callRange) $ \f -> do+        currentFile <- asksTC envCurrentPath+        when (currentFile /= Just f) $ do+          reportSLn "check.ranges" 90 $+            prettyShow call +++            " is setting the current range to " ++ show callRange +++            " which is outside of the current file " ++ show currentFile++    -- 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 ]           ]-        , [ \e -> e { envRange = callRange } | callHasRange ]-        ] -  -- For interactive highlighting, also wrap computation @m@ in 'highlightAsTypeChecked':-  ifNotM (pure highlightCall `and2M` do (Interactive ==) . envHighlightingLevel <$> askTC)-    {-then-} (withCall m)-    {-else-} $ do-      oldRange <- envHighlightingRange <$> askTC-      highlightAsTypeChecked oldRange callRange $-        withCall m-  where-  call = clValue cl-  callRange = getRange call-  callHasRange = not $ null callRange+    -- For interactive highlighting, also wrap computation @m@ in 'highlightAsTypeChecked':+    ifNotM (pure highlightCall `and2M` do (Interactive ==) . envHighlightingLevel <$> askTC)+      {-then-} (withCall m)+      {-else-} $ do+        oldRange <- envHighlightingRange <$> askTC+        highlightAsTypeChecked oldRange callRange $+          withCall m+    where+    call = clValue cl+    callRange = getRange call+    callHasRange = not $ null callRange -  -- | Should the given call trigger interactive highlighting?-  highlightCall = case call of-    CheckClause{}             -> True-    CheckLHS{}                -> True-    CheckPattern{}            -> True-    CheckLetBinding{}         -> True-    InferExpr{}               -> True-    CheckExprCall{}           -> True-    CheckDotPattern{}         -> True-    IsTypeCall{}              -> True-    IsType_{}                 -> True-    InferVar{}                -> True-    InferDef{}                -> True-    CheckArguments{}          -> True-    CheckMetaSolution{}       -> False-    CheckTargetType{}         -> False-    CheckDataDef{}            -> True-    CheckRecDef{}             -> True-    CheckConstructor{}        -> True-    CheckConstructorFitsIn{}  -> False-    CheckFunDefCall{}         -> True-    CheckPragma{}             -> True-    CheckPrimitive{}          -> True-    CheckIsEmpty{}            -> True-    CheckConfluence{}         -> False-    CheckWithFunctionType{}   -> True-    CheckSectionApplication{} -> True-    CheckNamedWhere{}         -> False-    ScopeCheckExpr{}          -> False-    ScopeCheckDeclaration{}   -> False-    ScopeCheckLHS{}           -> False-    NoHighlighting{}          -> True-    CheckProjection{}         -> False-    SetRange{}                -> False-    ModuleContents{}          -> False+    -- Should the given call trigger interactive highlighting?+    highlightCall = case call of+      CheckClause{}             -> True+      CheckLHS{}                -> True+      CheckPattern{}            -> True+      CheckPatternLinearityType{}  -> False+      CheckPatternLinearityValue{} -> False+      CheckLetBinding{}         -> True+      InferExpr{}               -> True+      CheckExprCall{}           -> True+      CheckDotPattern{}         -> True+      IsTypeCall{}              -> True+      IsType_{}                 -> True+      InferVar{}                -> True+      InferDef{}                -> True+      CheckArguments{}          -> True+      CheckMetaSolution{}       -> False+      CheckTargetType{}         -> False+      CheckDataDef{}            -> True+      CheckRecDef{}             -> True+      CheckConstructor{}        -> True+      CheckConstructorFitsIn{}  -> False+      CheckFunDefCall _ _ _ h   -> h+      CheckPragma{}             -> True+      CheckPrimitive{}          -> True+      CheckIsEmpty{}            -> True+      CheckConfluence{}         -> False+      CheckWithFunctionType{}   -> True+      CheckSectionApplication{} -> True+      CheckNamedWhere{}         -> False+      ScopeCheckExpr{}          -> False+      ScopeCheckDeclaration{}   -> False+      ScopeCheckLHS{}           -> False+      NoHighlighting{}          -> True+      CheckProjection{}         -> False+      SetRange{}                -> False+      ModuleContents{}          -> False -  isNoHighlighting = case call of-    NoHighlighting{} -> True-    _ -> False+    isNoHighlighting = case call of+      NoHighlighting{} -> True+      _ -> False +  printHighlightingInfo remove info = do+    modToSrc <- useTC stModuleToSource+    method   <- viewTC eHighlightingMethod+    reportS "highlighting" 50+      [ "Printing highlighting info:"+      , show info+      , "  modToSrc = " ++ show modToSrc+      ]+    unless (null info) $ do+      appInteractionOutputCallback $+          Resp_HighlightingInfo info remove method modToSrc++ getCurrentRange :: MonadTCEnv m => m Range getCurrentRange = asksTC envRange  -- | Sets the current range (for error messages etc.) to the range --   of the given object, if it has a range (i.e., its range is not 'noRange').-setCurrentRange :: (MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x)-                => x -> tcm a -> tcm a+setCurrentRange :: (MonadTrace m, HasRange x) => x -> m a -> m a setCurrentRange x = applyUnless (null r) $ traceCall $ SetRange r   where r = getRange x @@ -201,11 +240,11 @@ --   highlighted as being type-checked.  highlightAsTypeChecked-  :: (MonadTCM tcm, ReadTCState tcm)+  :: (MonadTrace m)   => Range   -- ^ @rPre@   -> Range   -- ^ @r@-  -> tcm a-  -> tcm a+  -> m a+  -> m a highlightAsTypeChecked rPre r m   | r /= noRange && delta == rPre' = wrap r'    highlight clear   | otherwise                      = wrap delta clear     highlight@@ -222,23 +261,4 @@     p rs y     return v     where-    p rs x = printHighlightingInfo KeepHighlighting (singletonC rs x)---- | Lispify and print the given highlighting information.--printHighlightingInfo ::-  (MonadTCM tcm, ReadTCState tcm) =>-  RemoveTokenBasedHighlighting ->-  HighlightingInfo ->-  tcm ()-printHighlightingInfo remove info = do-  modToSrc <- useTC stModuleToSource-  method   <- viewTC eHighlightingMethod-  liftTCM $ reportS "highlighting" 50-    [ "Printing highlighting info:"-    , show info-    , "  modToSrc = " ++ show modToSrc-    ]-  unless (null $ ranges info) $ do-    liftTCM $ appInteractionOutputCallback $-        Resp_HighlightingInfo info remove method modToSrc+    p rs x = printHighlightingInfo KeepHighlighting (singleton rs x)

src/full/Agda/TypeChecking/Names.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}  {-| EDSL to construct terms without touching De Bruijn indices. @@ -21,8 +19,10 @@ -} module Agda.TypeChecking.Names where +-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State @@ -32,11 +32,9 @@ import Agda.Syntax.Internal  import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst)-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free -import Agda.Utils.Except import Agda.Utils.Fail (Fail, runFail_)  instance HasBuiltins m => HasBuiltins (NamesT m) where@@ -59,6 +57,8 @@            , MonadReduce            , MonadError e            , MonadAddContext+           , HasConstInfo+           , PureTCM            )  -- deriving instance MonadState s m => MonadState s (NamesT m)@@ -82,7 +82,7 @@      then return $ raiseS (genericLength ctx' - genericLength ctx)      else fail $ "thing out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")" -inCxt :: (MonadFail m, Subst t a) => Names -> a -> NamesT m a+inCxt :: (MonadFail m, Subst a) => Names -> a -> NamesT m a inCxt ctx a = do   sigma <- cxtSubst ctx   return $ applySubst sigma a@@ -94,20 +94,20 @@ cl :: Monad m => m a -> NamesT m a cl = lift -open :: (MonadFail m, Subst t a) => a -> NamesT m (NamesT m a)+open :: (MonadFail m, Subst a) => a -> NamesT m (NamesT m a) open a = do   ctx <- NamesT ask   pure $ inCxt ctx a -bind' :: (MonadFail m, Subst t' b, DeBruijn b, Subst t a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a+bind' :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a bind' n f = do   cxt <- NamesT ask   (NamesT . local (n:) . unName $ f (inCxt (n:cxt) (deBruijnVar 0)))  bind :: ( MonadFail m-        , Subst t' b+        , Subst b         , DeBruijn b-        , Subst t a+        , Subst a         , Free a         ) =>         ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)

src/full/Agda/TypeChecking/Patterns/Abstract.hs view

@@ -1,10 +1,11 @@-{-# LANGUAGE TypeFamilies #-}  -- | Tools to manipulate patterns in abstract syntax --   in the TCM (type checking monad).  module Agda.TypeChecking.Patterns.Abstract where +import Control.Monad.Except+ import qualified Data.List as List import Data.Void @@ -19,27 +20,28 @@ import Agda.Syntax.Position  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Warnings (raiseWarningsOnUsage)  import Agda.Utils.Impossible  -- | Expand literal integer pattern into suc/zero constructor patterns. ---expandLitPattern :: A.Pattern -> TCM A.Pattern-expandLitPattern p = case asView p of-  (xs, A.LitP (LitNat r n))+expandLitPattern+  :: (MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m)+  => A.Pattern -> m A.Pattern+expandLitPattern = \case+  A.LitP info (LitNat n)     | n < 0     -> negLit -- Andreas, issue #2365, negative literals not yet supported.     | n > 20    -> tooBig     | otherwise -> do       Con z _ _ <- primZero       Con s _ _ <- primSuc+      let r     = getRange info       let zero  = A.ConP cinfo (unambiguous $ setRange r $ conName z) []           suc p = A.ConP cinfo (unambiguous $ setRange r $ conName s) [defaultNamedArg p]-          info  = A.PatRange r           cinfo = A.ConPatInfo ConOCon info ConPatEager-          p'    = foldr ($) zero $ List.genericReplicate n suc-      return $ foldr (A.AsP info) p' (map A.mkBindName xs)-  _ -> return p+      return $ foldr ($) zero $ List.genericReplicate n suc+  p -> return p    where     tooBig = typeError $ GenericError $@@ -74,6 +76,15 @@   A.PatternSynP i x as -> setCurrentRange i $ do     (ns, p) <- killRange <$> lookupPatternSyn x +    -- Andreas, 2020-02-11, issue #3734+    -- If lookup of ambiguous pattern synonym was successful,+    -- we are justified to complain if one of the definitions+    -- involved in the resolution is tagged with a warning.+    -- 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+     -- Must expand arguments before instantiating otherwise pattern     -- synonyms could get into dot patterns (which is __IMPOSSIBLE__).     p <- expandPatternSynonyms' (vacuous p :: A.Pattern' e)@@ -94,11 +105,11 @@     :: (Traversable f, ExpandPatternSynonyms b, f b ~ a) => a -> TCM a   expandPatternSynonyms = traverse expandPatternSynonyms -instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Maybe a)            where-instance ExpandPatternSynonyms a => ExpandPatternSynonyms [a]                  where-instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Arg a)              where-instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Named n a)          where-instance ExpandPatternSynonyms a => ExpandPatternSynonyms (FieldAssignment' a) where+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Maybe a)+instance ExpandPatternSynonyms a => ExpandPatternSynonyms [a]+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Arg a)+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Named n a)+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (FieldAssignment' a)  instance ExpandPatternSynonyms (A.Pattern' e) where   expandPatternSynonyms = expandPatternSynonyms'

src/full/Agda/TypeChecking/Patterns/Internal.hs view

@@ -14,7 +14,6 @@ import Agda.Syntax.Internal.Pattern  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Reduce (reduce) import Agda.TypeChecking.Substitute.DeBruijn

src/full/Agda/TypeChecking/Patterns/Match.hs view

@@ -10,7 +10,6 @@ import Control.Monad import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.Traversable (traverse)  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -24,9 +23,8 @@ import Agda.TypeChecking.Records  import Agda.Utils.Empty-import Agda.Utils.Functor (for, ($>))+import Agda.Utils.Functor (for, ($>), (<&>)) import Agda.Utils.Maybe-import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Singleton import Agda.Utils.Size@@ -47,14 +45,19 @@   null _              = False  matchedArgs :: Empty -> Int -> IntMap (Arg a) -> [Arg a]-matchedArgs err n vs = map get [0..n-1]+matchedArgs err n vs = map (fromMaybe (absurd err)) $ matchedArgs' n vs++matchedArgs' :: Int -> IntMap (Arg a) -> [Maybe (Arg a)]+matchedArgs' n vs = map get [0 .. n - 1]   where-    get k = fromMaybe (absurd err) $ IntMap.lookup k vs+    get k = IntMap.lookup k vs  -- | Builds a proper substitution from an IntMap produced by match(Co)patterns buildSubstitution :: (DeBruijn a)-                  => Empty -> Int -> IntMap (Arg a) -> Substitution' a-buildSubstitution err n vs = parallelS $ map unArg $ matchedArgs err n vs+                  => Impossible -> Int -> IntMap (Arg a) -> Substitution' a+buildSubstitution err n vs = foldr cons idS $ matchedArgs' n vs+  where cons Nothing  = Strengthen err+        cons (Just v) = consS (unArg v)   instance Semigroup (Match a) where@@ -92,10 +95,11 @@ -- upon failure, no further matching is performed.  foldMatch-  :: forall p v . IsProjP p => (p -> v -> ReduceM (Match Term, v))-  -> [p] -> [v] -> ReduceM (Match Term, [v])+  :: forall m p v . (IsProjP p, MonadMatch m)+  => (p -> v -> m (Match Term, v))+  -> [p] -> [v] -> m (Match Term, [v]) foldMatch match = loop where-  loop :: [p] -> [v] -> ReduceM (Match Term, [v])+  loop :: [p] -> [v] -> m (Match Term, [v])   loop ps0 vs0 = do     case (ps0, vs0) of       ([], []) -> return (empty, [])@@ -129,6 +133,8 @@ mergeElims :: [Elim] -> [Arg Term] -> [Elim] mergeElims = zipWith mergeElim +type MonadMatch m = PureTCM m+ -- | @matchCopatterns ps es@ matches spine @es@ against copattern spine @ps@. -- --   Returns 'Yes' and a substitution for the pattern variables@@ -142,9 +148,10 @@ --   In any case, also returns spine @es@ in reduced form --   (with all the weak head reductions performed that were necessary --   to come to a decision).-matchCopatterns :: [NamedArg DeBruijnPattern]+matchCopatterns :: MonadMatch m+                => [NamedArg DeBruijnPattern]                 -> [Elim]-                -> ReduceM (Match Term, [Elim])+                -> m (Match Term, [Elim]) matchCopatterns ps vs = do   traceSDoc "tc.match" 50     (vcat [ "matchCopatterns"@@ -156,12 +163,15 @@   foldMatch (matchCopattern . namedArg) ps vs  -- | Match a single copattern.-matchCopattern :: DeBruijnPattern+matchCopattern :: MonadMatch m+               => DeBruijnPattern                -> Elim-               -> ReduceM (Match Term, Elim)+               -> m (Match Term, Elim) matchCopattern pat@ProjP{} elim@(Proj _ q) = do-  ProjP _ p <- normaliseProjP pat-  q         <- getOriginalProjection q+  p <- normaliseProjP pat <&> \case+         ProjP _ p -> p+         _         -> __IMPOSSIBLE__+  q       <- getOriginalProjection q   return $ if p == q then (Yes YesSimplification empty, elim)                      else (No,                          elim) -- The following two cases are not impossible, see #2964@@ -170,9 +180,10 @@ matchCopattern p       (Apply v) = mapSnd Apply <$> matchPattern p v matchCopattern p       e@(IApply x y r) = mapSnd (mergeElim e) <$> matchPattern p (defaultArg r) -matchPatterns :: [NamedArg DeBruijnPattern]+matchPatterns :: MonadMatch m+              => [NamedArg DeBruijnPattern]               -> [Arg Term]-              -> ReduceM (Match Term, [Arg Term])+              -> m (Match Term, [Arg Term]) matchPatterns ps vs = do   reportSDoc "tc.match" 20 $      vcat [ "matchPatterns"@@ -191,9 +202,10 @@   foldMatch (matchPattern . namedArg) ps vs  -- | Match a single pattern.-matchPattern :: DeBruijnPattern+matchPattern :: MonadMatch m+             => DeBruijnPattern              -> Arg Term-             -> ReduceM (Match Term, Arg Term)+             -> m (Match Term, Arg Term) matchPattern p u = case (p, u) of   (ProjP{}, _            ) -> __IMPOSSIBLE__   (IApplyP _ _ _ x , arg ) -> return (Yes NoSimplification entry, arg)@@ -202,14 +214,13 @@     where entry = singleton (dbPatVarIndex x, arg)   (DotP _ _ , arg@(Arg _ v)) -> return (Yes NoSimplification empty, arg)   (LitP _ l , arg@(Arg _ v)) -> do-    w <- reduceB' v+    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')-      NotBlocked _ (MetaV x _) -> return (DontKnow $ Blocked x ()     , arg')-      Blocked x _              -> return (DontKnow $ Blocked x ()     , arg')+      Blocked b _              -> return (DontKnow $ Blocked b ()     , arg')       NotBlocked r t           -> return (DontKnow $ NotBlocked r' () , arg')         where r' = stuckOn (Apply arg') r @@ -226,7 +237,7 @@         mapSnd (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do           matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f]     where-    isEtaRecordCon :: QName -> ReduceM (Maybe [Arg QName])+    isEtaRecordCon :: HasConstInfo m => QName -> m (Maybe [Arg QName])     isEtaRecordCon c = do       (theDef <$> getConstInfo c) >>= \case         Constructor{ conData = d } -> do@@ -240,14 +251,16 @@     fallback' f ps v  where     -- Default: not an eta record constructor.+  fallback :: MonadMatch m+           => ConHead -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term)   fallback c ps v = do-    isMatchable <- isMatchable'     let f (Con c' ci' vs) | c == c' = Just (Con c' ci',vs)         f _                         = Nothing     fallback' f 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 ->@@ -258,10 +271,15 @@         _       -> Nothing    -- DefP hcomp and ConP matching.+  fallback' :: MonadMatch m+            => (Term -> Maybe (Elims -> Term , Elims))+            -> [NamedArg DeBruijnPattern]+            -> Arg Term+            -> m (Match Term, Arg Term)   fallback' mtc ps (Arg info v) = do         isMatchable <- isMatchable' -        w <- reduceB' v+        w <- reduceB v         -- Unfold delayed (corecursive) definitions one step. This is         -- only necessary if c is a coinductive constructor, but         -- 1) it does not hurt to do it all the time, and@@ -280,7 +298,7 @@         -- Jesper, 23-06-2016: Note that unfoldCorecursion may destroy         -- constructor forms, so we only call constructorForm after.         w <- traverse constructorForm =<< case w of-               NotBlocked r u -> unfoldCorecursion u  -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?+               NotBlocked r u -> liftReduce $ unfoldCorecursion u  -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?                _ -> return w         let v = ignoreBlocking w             arg = Arg info v  -- the reduced argument@@ -293,8 +311,7 @@                 return (m, Arg info $ bld (mergeElims vs vs1))               Nothing                                     -> return (No                          , arg)-          NotBlocked _ (MetaV x vs) -> return (DontKnow $ Blocked x ()     , arg)-          Blocked x _               -> return (DontKnow $ Blocked x ()     , arg)+          Blocked b _               -> return (DontKnow $ Blocked b ()     , arg)           NotBlocked r _            -> return (DontKnow $ NotBlocked r' () , arg)             where r' = stuckOn (Apply arg) r @@ -308,9 +325,10 @@ -- Matching patterns against patterns -------------------------------------  -- | Match a single pattern.-matchPatternP :: DeBruijnPattern-             -> Arg DeBruijnPattern-             -> ReduceM (Match DeBruijnPattern)+matchPatternP :: MonadMatch m+              => DeBruijnPattern+              -> Arg DeBruijnPattern+              -> m (Match DeBruijnPattern) matchPatternP p (Arg info (DotP _ v)) = do   (m, arg) <- matchPattern p (Arg info v)   return $ fmap (DotP defaultPatternInfo) m@@ -336,8 +354,9 @@                 toLitP _                = __IMPOSSIBLE__         _      -> termMatch -matchPatternsP :: [NamedArg DeBruijnPattern]+matchPatternsP :: MonadMatch m+               => [NamedArg DeBruijnPattern]                -> [Arg DeBruijnPattern]-               -> ReduceM (Match DeBruijnPattern)+               -> m (Match DeBruijnPattern) matchPatternsP ps qs = do   mconcat <$> zipWithM matchPatternP (map namedArg ps) qs

src/full/Agda/TypeChecking/Patterns/Match.hs-boot view

@@ -8,11 +8,13 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute (DeBruijn) -import Agda.Utils.Empty+import Agda.Utils.Impossible  data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow (Blocked ()) -buildSubstitution :: (DeBruijn a) => Empty -> Int -> IntMap (Arg a) -> Substitution' a+buildSubstitution :: (DeBruijn a) => Impossible -> Int -> IntMap (Arg a) -> Substitution' a -matchPatterns   :: [NamedArg DeBruijnPattern] -> Args  -> ReduceM (Match Term, Args)-matchCopatterns :: [NamedArg DeBruijnPattern] -> Elims -> ReduceM (Match Term, Elims)+type MonadMatch m = PureTCM m++matchPatterns   :: MonadMatch m => [NamedArg DeBruijnPattern] -> Args -> m (Match Term, Args)+matchCopatterns :: MonadMatch m => [NamedArg DeBruijnPattern] -> Elims -> m (Match Term, Elims)

src/full/Agda/TypeChecking/Polarity.hs view

@@ -1,9 +1,20 @@+-- | Computing the polarity (variance) of function arguments,+--   for the sake of subtyping. -module Agda.TypeChecking.Polarity where+module Agda.TypeChecking.Polarity+  ( -- * Polarity computation+    computePolarity+    -- * Auxiliary functions+  , composePol+  , nextPolarity+  , purgeNonvariant+  , polFromOcc+  ) where  import Control.Monad.State  import Data.Maybe+import Data.Semigroup (Semigroup(..))  import Agda.Syntax.Abstract.Name import Agda.Syntax.Common@@ -23,6 +34,7 @@ import Agda.Utils.Maybe ( whenNothingM ) import Agda.Utils.Monad import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Singleton import Agda.Utils.Size  import Agda.Utils.Impossible@@ -56,7 +68,7 @@ composePol Contravariant x = neg x  polFromOcc :: Occurrence -> Polarity-polFromOcc o = case o of+polFromOcc = \case   GuardPos  -> Covariant   StrictPos -> Covariant   JustPos   -> Covariant@@ -80,7 +92,9 @@   -- | A quick transliterations of occurrences to polarities.-polarityFromPositivity :: QName -> TCM ()+polarityFromPositivity+  :: (HasConstInfo m, MonadTCEnv m, MonadTCState m, MonadDebug m)+  => QName -> m () polarityFromPositivity x = inConcreteOrAbstractMode x $ \ def -> do    -- Get basic polarity from positivity analysis.@@ -97,7 +111,11 @@ ------------------------------------------------------------------------  -- | Main function of this module.-computePolarity :: [QName] -> TCM ()+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   -- Andreas, 2017-04-26, issue #2554@@ -185,7 +203,9 @@ --   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 :: Type -> [Polarity] -> [Polarity] -> TCM [Polarity]+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@@ -210,14 +230,15 @@  -- | Check whether a variable is relevant in a type expression, --   ignoring domains of non-variant arguments.-relevantInIgnoringNonvariant :: Nat -> Type -> [Polarity] -> TCM Bool+relevantInIgnoringNonvariant :: MonadReduce m => Nat -> Type -> [Polarity] -> m Bool relevantInIgnoringNonvariant i t []     = return $ i `relevantInIgnoringSortAnn` t-relevantInIgnoringNonvariant i t (p:ps) = do-  t <- reduce $ unEl t-  case t of-    Pi a b -> if p /= Nonvariant && i `relevantInIgnoringSortAnn` a then return True-              else relevantInIgnoringNonvariant (i + 1) (absBody b) ps-    _ -> 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  ------------------------------------------------------------------------ -- * Sized types@@ -226,7 +247,12 @@ -- | 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 :: QName -> [Polarity] -> TCM [Polarity]+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 d pol0 = do   let exit = return pol0   ifNotM sizedTypesOption exit $ {- else -} do@@ -244,36 +270,45 @@                 polIn = pol ++ [Invariant]             setPolarity d $ polCo             -- and seek confirm it by looking at the constructor types-            let check c = do+            let check :: QName -> m Bool+                check c = do                   t <- defType <$> getConstInfo c                   addContext (telFromList parTel) $ do                     let pars = map (defaultArg . var) $ downFrom np                     TelV conTel target <- telView =<< (t `piApplyM` pars)-                    case conTel of-                      EmptyTel  -> return False  -- no size argument-                      ExtendTel arg  tel ->-                        ifM ((/= Just BoundedNo) <$> isSizeType (unDom arg)) (return False) $ do -- also no size argument-                          -- First constructor argument has type Size+                    loop target conTel+                  where+                  loop :: Type -> Telescope -> m Bool+                  -- no suitable size argument+                  loop _ EmptyTel = do+                    reportSDoc "tc.polarity.size" 15 $+                      "constructor" <+> prettyTCM c <+> "fails size polarity check"+                    return False -                          -- check that only positive occurences in tel-                          let isPos = underAbstraction arg tel $ \ tel -> do-                                pols <- zipWithM polarity [0..] $ map (snd . unDom) $ telToList tel-                                reportSDoc "tc.polarity.size" 25 $-                                  text $ "to pass size polarity check, the following polarities need all to be covariant: " ++ prettyShow pols-                                return $ all (`elem` [Nonvariant, Covariant]) pols+                  -- try argument @dom@+                  loop target (ExtendTel dom tel) = do+                    isSz <- isSizeType dom+                    underAbstraction dom tel $ \ tel -> do+                      let continue = loop target tel -                          -- check that the size argument appears in the-                          -- right spot in the target type-                          let sizeArg = size tel-                              isLin = addContext conTel $ checkSizeIndex d sizeArg target+                      -- check that dom == Size+                      if isSz /= Just BoundedNo then continue else do -                          ok <- isPos `and2M` isLin-                          reportSDoc "tc.polarity.size" 15 $-                            "constructor" <+> prettyTCM c <+>-                            text (if ok then "passes" else "fails") <+>-                            "size polarity check"-                          return ok+                        -- check that the size argument appears in the+                        -- right spot in the target type+                        let sizeArg = size tel+                        isLin <- addContext tel $ checkSizeIndex d sizeArg target+                        if not isLin then continue else do +                          -- check that only positive occurences in tel+                          pols <- zipWithM polarity [0..] $ map (snd . unDom) $ telToList tel+                          reportSDoc "tc.polarity.size" 25 $+                            text $ "to pass size polarity check, the following polarities need all to be covariant: " ++ prettyShow pols+                          if any (`notElem` [Nonvariant, Covariant]) pols then continue else do+                            reportSDoc "tc.polarity.size" 15 $+                              "constructor" <+> prettyTCM c <+> "passes size polarity check"+                            return True+             ifNotM (andM $ map check cons)                 (return polIn) -- no, does not conform to the rules of sized types               $ do  -- yes, we have a sized type here@@ -288,7 +323,9 @@ --   has form @d ps (↑ⁿ i) idxs@ where @|ps| = np(d)@. -- --   Precondition: @a@ is reduced and of form @d ps idxs0@.-checkSizeIndex :: QName -> Nat -> Type -> TCM Bool+checkSizeIndex+  :: (HasConstInfo m, ReadTCState m, MonadDebug m, MonadPretty m, MonadTCError m)+  => QName -> Nat -> Type -> m Bool checkSizeIndex d i a = do   reportSDoc "tc.polarity.size" 15 $ withShowAllArguments $ vcat     [ "checking that constructor target type " <+> prettyTCM a@@ -302,80 +339,88 @@       let (pars, Apply ix : ixs) = splitAt np es       s <- deepSizeView $ unArg ix       case s of-        DSizeVar j _ | i == j+        DSizeVar (ProjectedVar j []) _ | i == j           -> return $ not $ freeIn i (pars ++ ixs)         _ -> return False     _ -> __IMPOSSIBLE__ --- | @polarities i a@ computes the list of polarities of de Bruijn index @i@+-- | @polarity i a@ computes the least polarity of de Bruijn index @i@ --   in syntactic entity @a@.-class HasPolarity a where-  polarities :: Nat -> a -> TCM [Polarity]+polarity+  :: (HasPolarity a, HasConstInfo m, MonadReduce m)+  => Nat -> a -> m Polarity+polarity i x = getLeastPolarity $ polarity' i Covariant x --- | @polarity i a@ computes the polarity of de Bruijn index @i@---   in syntactic entity @a@ by taking the infimum of all 'polarities'.-polarity :: HasPolarity a => Nat -> a -> TCM Polarity-polarity i x = do-  ps <- polarities i x-  case ps of-    [] -> return Nonvariant-    ps -> return $ foldr1 (/\) ps+-- | A monoid for lazily computing the infimum of the polarities of a variable in some object.+-- Allows short-cutting. -instance HasPolarity a => HasPolarity (Arg a) where-  polarities i = polarities i . unArg+newtype LeastPolarity m = LeastPolarity { getLeastPolarity :: m Polarity} -instance HasPolarity a => HasPolarity (Dom a) where-  polarities i = polarities i . unDom+instance Monad m => Singleton Polarity (LeastPolarity m) where+  singleton = LeastPolarity . return -instance HasPolarity a => HasPolarity (Abs a) where-  polarities i (Abs   _ b) = polarities (i + 1) b-  polarities i (NoAbs _ v) = polarities i v+instance Monad m => Semigroup (LeastPolarity m) where+  LeastPolarity mp <> LeastPolarity mq = LeastPolarity $ do+    mp >>= \case+      Invariant  -> return Invariant  -- Shortcut for the absorbing element.+      Nonvariant -> mq                -- The neutral element.+      p          -> (p /\) <$> mq -instance HasPolarity a => HasPolarity [a] where-  polarities i xs = concat <$> mapM (polarities i) xs+instance Monad m => Monoid (LeastPolarity m) where+  mempty  = singleton Nonvariant+  mappend = (<>) -instance (HasPolarity a, HasPolarity b) => HasPolarity (a, b) where-  polarities i (x, y) = (++) <$> polarities i x <*> polarities i y+-- | Bind for 'LeastPolarity'.+(>>==) :: Monad m => m a -> (a -> LeastPolarity m) -> LeastPolarity m+m >>== k = LeastPolarity $ m >>= getLeastPolarity . k -instance HasPolarity Type where-  polarities i (El _ v) = polarities i v+-- | @polarity' i p a@ computes the least polarity of de Bruijn index @i@+--   in syntactic entity @a@, where root occurrences count as @p@.+--+--   Ignores occurrences in sorts.+class HasPolarity a where+  polarity'+    :: (HasConstInfo m, MonadReduce m)+    => Nat -> Polarity -> a -> LeastPolarity m -instance HasPolarity a => HasPolarity (Elim' a) where-  polarities i Proj{}    = return []-  polarities i (Apply a) = polarities i a-  polarities i (IApply x y a) = polarities i (x,(y,a))+  default polarity'+    :: (HasConstInfo m, MonadReduce m, HasPolarity b, Foldable t, t b ~ a)+    => Nat -> Polarity -> a -> LeastPolarity m+  polarity' i = foldMap . polarity' i -instance HasPolarity Term where-  polarities i v = do-   v <- instantiate v-   case v of-    -- Andreas, 2012-09-06: taking the polarities of the arguments-    -- without taking the variance of the function into account seems wrong.-    Var n ts  | n == i -> (Covariant :) . map (const Invariant) <$> polarities i ts-              | otherwise -> map (const Invariant) <$> polarities i ts-    Lam _ t    -> polarities i t-    Lit _      -> return []-    Level l    -> polarities i l-    Def x ts   -> do-      pols <- getPolarity x-      let compose p ps = map (composePol p) ps-      concat . zipWith compose (pols ++ repeat Invariant) <$> mapM (polarities i) ts-    Con _ _ ts -> polarities i ts -- constructors can be seen as monotone in all args.-    Pi a b     -> (++) <$> (map neg <$> polarities i a) <*> polarities i b-    Sort s     -> return [] -- polarities i s -- return []-    MetaV _ ts -> map (const Invariant) <$> polarities i ts-    DontCare t -> polarities i t -- return []-    Dummy{}    -> return []+instance HasPolarity a => HasPolarity [a]+instance HasPolarity a => HasPolarity (Arg a)+instance HasPolarity a => HasPolarity (Dom a)+instance HasPolarity a => HasPolarity (Elim' a)+instance HasPolarity a => HasPolarity (Level' a)+instance HasPolarity a => HasPolarity (PlusLevel' a) -instance HasPolarity Level where-  polarities i (Max _ as) = polarities i as+-- | Does not look into sort.+instance HasPolarity a => HasPolarity (Type'' t a) -instance HasPolarity PlusLevel where-  polarities i (Plus _ l) = polarities i l+instance (HasPolarity a, HasPolarity b) => HasPolarity (a, b) where+  polarity' i p (x, y) = polarity' i p x <> polarity' i p y -instance HasPolarity LevelAtom where-  polarities i l = case l of-    MetaLevel _ vs   -> map (const Invariant) <$> polarities i vs-    BlockedLevel _ v -> polarities i v-    NeutralLevel _ v -> polarities i v-    UnreducedLevel v -> polarities i v+instance HasPolarity a => HasPolarity (Abs a) where+  polarity' i p (Abs   _ b) = polarity' (i + 1) p b+  polarity' i p (NoAbs _ v) = polarity' i p v++instance HasPolarity Term where+  polarity' i p v = instantiate v >>== \case+    -- Andreas, 2012-09-06: taking the polarity' of the arguments+    -- without taking the variance of the function into account seems wrong.+    Var n ts+      | n == i    -> singleton p <> polarity' i Invariant ts+      | otherwise -> polarity' i Invariant ts+    Lam _ t       -> polarity' i p t+    Lit _         -> mempty+    Level l       -> polarity' i p l+    Def x ts      -> getPolarity x >>== \ pols ->+                       let ps = map (composePol p) pols ++ repeat 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+    Sort s        -> mempty -- polarity' i p s -- mempty+    MetaV _ ts    -> polarity' i Invariant ts+    DontCare t    -> polarity' i p t -- mempty+    Dummy{}       -> mempty

src/full/Agda/TypeChecking/Polarity.hs-boot view

@@ -1,8 +1,18 @@  module Agda.TypeChecking.Polarity where -import Agda.Syntax.Internal+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 :: [QName] -> TCM ()+computePolarity+  :: ( HasOptions m, HasConstInfo m, HasBuiltins m+     , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m+     , MonadDebug m, MonadPretty m )+  => [QName] -> m ()+ composePol      :: Polarity -> Polarity -> Polarity

src/full/Agda/TypeChecking/Positivity.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE TypeFamilies         #-}  -- for type equality ~-{-# LANGUAGE UndecidableInstances #-}  -- | Check that a datatype is strictly positive. module Agda.TypeChecking.Positivity where@@ -20,7 +17,6 @@ import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid (mconcat) import Data.Sequence (Seq) import qualified Data.Sequence as DS import Data.Set (Set)@@ -35,7 +31,6 @@ import Agda.TypeChecking.Datatypes ( isDataOrRecordType ) import Agda.TypeChecking.Functions import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (builtinInf, getBuiltin', CoinductionKit(..), coinductionKit) import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records@@ -78,7 +73,7 @@   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)+    [ "positivity graph for" <+> fsep (map prettyTCM qs)     , nest 2 $ prettyTCM g     ]   reportSLn "tc.pos.graph" 5 $@@ -162,11 +157,12 @@             _ -> return ()          -- if we find an unguarded record, mark it as such-        when (dr == IsRecord) $-          case loop of+        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+              unguardedRecord q pat               checkInduction q             -- otherwise, if the record is recursive, mark it as well             Just o | o <= GuardPos -> do@@ -204,7 +200,7 @@       def <- theDef <$> getConstInfo q       return $ case def of         Datatype{dataClause = Nothing} -> Just IsData-        Record  {recClause  = Nothing} -> Just IsRecord+        Record  {recClause  = Nothing, recPatternMatching } -> Just $ IsRecord recPatternMatching         _ -> Nothing      -- Set the mutually recursive identifiers for a SCC.@@ -256,6 +252,7 @@         GeneralizableVar{} -> False         AbstractDefn{}     -> False         Primitive{}        -> False+        PrimitiveSort{}    -> False         Constructor{}      -> False         Function{}         -> True         Datatype{}         -> True@@ -281,6 +278,10 @@   getRange (AnArg _) = noRange   getRange (ADef qn)   = getRange qn +instance Pretty Item where+  prettyPrec p (AnArg i) = P.mparens (p > 9) $ "AnArg" P.<+> P.pretty i+  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.@@ -314,9 +315,8 @@   Nothing -> Concat' []   Just ob -> ob   where-  pp :: Maybe Nat-        -- ^ Variables larger than or equal to this number, if any,-        --   are not retained.+  pp :: Maybe Nat  -- Variables larger than or equal to this number, if any,+                   -- are not retained.      -> OccurrencesBuilder      -> Maybe OccurrencesBuilder'   pp !m = \case@@ -372,9 +372,6 @@ -- | Monad for computing occurrences. type OccM = Reader OccEnv -instance Semigroup a => Semigroup (OccM a) where-  ma <> mb = liftA2 (<>) ma mb- instance (Semigroup a, Monoid a) => Monoid (OccM a) where   mempty  = return mempty   mappend = (<>)@@ -395,8 +392,7 @@ 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-  kit <- coinductionKit-  return $ runReader (occurrences a) $ OccEnv vars $ fmap nameOfInf kit+  runReader (occurrences a) . OccEnv vars . fmap nameOfInf <$> coinductionKit  class ComputeOccurrences a where   occurrences :: a -> OccM OccurrencesBuilder@@ -431,7 +427,7 @@  instance ComputeOccurrences Term where   occurrences v = case unSpine v of-    Var i args -> (occI <$> asks vars) <> (OccursAs VarArg <$> occurrences args)+    Var i args -> (asks (occI . vars)) <> (OccursAs VarArg <$> occurrences args)       where       occI vars = maybe mempty OccursHere $ indexWithDefault unbound vars i       unbound = flip trace __IMPOSSIBLE__ $@@ -465,14 +461,6 @@ instance ComputeOccurrences PlusLevel where   occurrences (Plus _ l) = occurrences l -instance ComputeOccurrences LevelAtom where-  occurrences = occurrences . unLevelAtom-      -- MetaLevel x es -> occurrences $ MetaV x es-      -- Andreas, 2016-07-25, issue 2108-      -- NOT: OccursAs MetaArg <$> occurrences es-      -- since we need to unSpine!-      -- (Otherwise, we run into __IMPOSSIBLE__ at Proj elims)- instance ComputeOccurrences Type where   occurrences (El _ v) = occurrences v @@ -542,13 +530,14 @@             -- in same way as it was obtained when the data types was checked.             TelV tel t <- putAllowedReductions allReductions $               telViewPath . 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.)-            tel' <- normalise $ telFromList $ drop np $ telToList tel+            tel1' <- addContext tel0 $ normalise $ tel1             let vars = map (Just . AnArg) . downFrom             -- Occurrences in the types of the constructor arguments.-            mappend (OccursAs (ConArgType c) <$> getOccurrences (vars np) tel') $ do+            mappend (OccursAs (ConArgType c) <$> getOccurrences (vars np) tel1') $ 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@@ -557,7 +546,7 @@               -- 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'.-              let fallback = OccursAs LeftOfArrow <$> getOccurrences (vars $ size tel) t+              let fallback = OccursAs LeftOfArrow <$> getOccurrences (vars $ size tel) t -- NB::Defined but not used               case unEl t of                 Def q' vs                   | q == q' -> do@@ -578,15 +567,16 @@      Record{recClause = Just c} -> getOccurrences [] =<< instantiateFull c     Record{recPars = np, recTel = tel} -> do-      let tel' = telFromList $ drop np $ telToList tel+      let (tel0,tel1) = splitTelescopeAt np tel           vars = map (Just . AnArg) $ downFrom np-      getOccurrences vars =<< normalise tel' -- Andreas, 2017-01-01, issue #1899, treat like data types+      getOccurrences vars =<< 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__ @@ -642,9 +632,9 @@       reportSDoc "tc.pos.occs" 40 $         (("Occurrences in" <+> prettyTCM q) <> ":")           $+$-        (nest 2 $ vcat $+        nest 2 (vcat $            map (\(i, n) ->-                   (text (show i) <> ":") <+> text (show n) <+>+                   (pretty i <> ":") <+> text (show n) <+>                    "occurrences") $            List.sortBy (compare `on` snd) $            Map.toList (flatten occs))@@ -656,7 +646,7 @@       reportSDoc "tc.pos.occs.edges" 60 $         "Edges:"           $+$-        (nest 2 $ vcat $+        nest 2 (vcat $            map (\e ->                    let Edge o w = Graph.label e in                    prettyTCM (Graph.source e) <+>@@ -701,14 +691,11 @@   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.+     -> 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@@ -742,14 +729,13 @@                , Graph.label  = Edge pol o                } :) -  -- | This function might return a new target node.+  -- This function might return a new target node.   mkEdge'-    :: Node-        -- ^ The current target node.+    :: Node  -- The current target node.     -> Occurrence     -> Where     -> TCM (Maybe Node, Occurrence)-  mkEdge' to !pol w = case w of+  mkEdge' to !pol = \case     VarArg         -> mixed     MetaArg        -> mixed     LeftOfArrow    -> negative@@ -789,8 +775,8 @@ instance PrettyTCM Node where   prettyTCM = return . P.pretty -instance PrettyTCM n => PrettyTCM (WithNode n (Edge OccursWhere)) where-  prettyTCM (WithNode n (Edge o w)) = vcat+instance PrettyTCMWithNode (Edge OccursWhere) where+  prettyTCMWithNode (WithNode n (Edge o w)) = vcat     [ prettyTCM o <+> prettyTCM n     , nest 2 $ return $ P.pretty w     ]@@ -837,7 +823,7 @@             Fold.foldrM (\w d -> return d $$ fsep (prettyW w)) empty ws        prettyW :: MonadPretty m => Where -> [m Doc]-      prettyW w = case w of+      prettyW = \case         LeftOfArrow  -> pwords "to the left of an arrow"         DefArg q i   -> pwords "in the" ++ nth i ++ pwords "argument of" ++                           [prettyTCM q]

src/full/Agda/TypeChecking/Positivity/Occurrence.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-- -- | Occurrences.  module Agda.TypeChecking.Positivity.Occurrence@@ -22,6 +19,7 @@ import qualified Data.Map.Strict as Map import Data.Sequence (Seq) +import GHC.Generics (Generic)  import Agda.Syntax.Common import Agda.Syntax.Abstract.Name@@ -48,8 +46,10 @@     -- includes the main information, and if the first sequence is     -- non-empty, then it includes information about the context of     -- the second sequence.-  deriving (Show, Eq, Ord, Data)+  deriving (Show, Eq, Ord, Data, Generic) +instance NFData OccursWhere+ -- | One part of the description of an occurrence. data Where   = LeftOfArrow@@ -63,7 +63,9 @@   | Matched          -- ^ matched against in a clause of a defined function   | IsIndex          -- ^ is an index of an inductive family   | InDefOf QName    -- ^ in the definition of a constant-  deriving (Show, Eq, Ord, Data)+  deriving (Show, Eq, Ord, Data, Generic)++instance NFData Where  -- | Subterm occurrences for positivity checking. --   The constructors are listed in increasing information they provide:

src/full/Agda/TypeChecking/Pretty.hs view

@@ -1,14 +1,17 @@-{-# LANGUAGE UndecidableInstances #-}  module Agda.TypeChecking.Pretty     ( module Agda.TypeChecking.Pretty-    -- This re-export can be removed once <GHC-8.4 is dropped.-    , module Data.Semigroup+    , module Data.Semigroup -- This re-export can be removed once <GHC-8.4 is dropped.+    , module Reexport     ) where  import Prelude hiding ( null ) +import Control.Applicative  (liftA2) import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader (ReaderT)+import Control.Monad.State  (StateT)  import Data.Map (Map) import qualified Data.Map as Map@@ -16,6 +19,7 @@ import Data.Maybe import Data.String import Data.Semigroup (Semigroup((<>)))+import qualified Data.Foldable as Fold  import Agda.Syntax.Position import Agda.Syntax.Common@@ -25,6 +29,7 @@ import Agda.Syntax.Translation.InternalToAbstract import Agda.Syntax.Translation.ReflectedToAbstract 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 qualified Agda.Syntax.Concrete as C@@ -32,17 +37,18 @@ 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.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (equalityUnview) import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Substitute -import Agda.Utils.Except import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph) import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph+import Agda.Utils.List1 ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Null import Agda.Utils.Permutation (Permutation)@@ -57,38 +63,38 @@  type Doc = P.Doc -comma, colon, equals :: Monad m => m Doc-comma  = return P.comma-colon  = return P.colon-equals = return P.equals+comma, colon, equals :: Applicative m => m Doc+comma  = pure P.comma+colon  = pure P.colon+equals = pure P.equals -pretty :: (Monad m, P.Pretty a) => a -> m Doc-pretty x = return $ P.pretty x+pretty :: (Applicative m, P.Pretty a) => a -> m Doc+pretty x = pure $ P.pretty x -prettyA :: (P.Pretty c, ToConcrete a c, MonadAbsToCon m) => a -> m Doc+prettyA :: (ToConcrete a, P.Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc prettyA x = AP.prettyA x -prettyAs :: (P.Pretty c, ToConcrete a [c], MonadAbsToCon m) => a -> m Doc+prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], P.Pretty ce, MonadAbsToCon m) => a -> m Doc prettyAs x = AP.prettyAs x -text :: Monad m => String -> m Doc-text s = return $ P.text s+text :: Applicative m => String -> m Doc+text s = pure $ P.text s -multiLineText :: Monad m => String -> m Doc-multiLineText s = return $ P.multiLineText s+multiLineText :: Applicative m => String -> m Doc+multiLineText s = pure $ P.multiLineText s -pwords :: Monad m => String -> [m Doc]-pwords s = map return $ P.pwords s+pwords :: Applicative m => String -> [m Doc]+pwords s = map pure $ P.pwords s -fwords :: Monad m => String -> m Doc-fwords s = return $ P.fwords s+fwords :: Applicative m => String -> m Doc+fwords s = pure $ P.fwords s -sep, fsep, hsep, hcat, vcat :: Monad m => [m Doc] -> m Doc-sep ds  = P.sep <$> sequence ds-fsep ds = P.fsep <$> sequence ds-hsep ds = P.hsep <$> sequence ds-hcat ds = P.hcat <$> sequence ds-vcat ds = P.vcat <$> sequence ds+sep, fsep, hsep, hcat, vcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc+sep ds  = P.sep  <$> sequenceA (Fold.toList ds)+fsep ds = P.fsep <$> sequenceA (Fold.toList ds)+hsep ds = P.hsep <$> sequenceA (Fold.toList ds)+hcat ds = P.hcat <$> sequenceA (Fold.toList ds)+vcat ds = P.vcat <$> sequenceA (Fold.toList ds)  hang :: Applicative m => m Doc -> Int -> m Doc -> m Doc hang p n q = P.hang <$> p <*> pure n <*> q@@ -105,28 +111,34 @@ nest :: Functor m => Int -> m Doc -> m Doc nest n d   = P.nest n <$> d -braces, dbraces, brackets, parens :: Functor m => m Doc -> m Doc+braces, dbraces, brackets, parens, parensNonEmpty+  , doubleQuotes, quotes :: Functor m => m Doc -> m Doc braces d   = P.braces <$> d dbraces d  = CP.dbraces <$> d brackets d = P.brackets <$> d parens d   = P.parens <$> d+parensNonEmpty d = P.parensNonEmpty <$> d+doubleQuotes   d = P.doubleQuotes   <$> d+quotes         d = P.quotes         <$> d  pshow :: (Applicative m, Show a) => a -> m Doc pshow = pure . P.pshow  -- | Comma-separated list in brackets.-prettyList :: (Monad m, Semigroup (m Doc)) => [m Doc] -> m Doc-prettyList ds = P.pretty <$> sequence ds+prettyList :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc+prettyList ds = P.pretty <$> sequenceA (Fold.toList ds)  -- | 'prettyList' without the brackets.-prettyList_ :: (Monad m, Semigroup (m Doc)) => [m Doc] -> m Doc+prettyList_ :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc prettyList_ ds = fsep $ punctuate comma ds -punctuate :: (Applicative m, Semigroup (m Doc)) => m Doc -> [m Doc] -> [m Doc]-punctuate _ [] = []-punctuate d ds = zipWith (<>) ds (replicate n d ++ [pure empty])+punctuate :: (Applicative m, Semigroup (m Doc), Foldable t) => m Doc -> t (m Doc) -> [m Doc]+punctuate d ts+  | null ds   = []+  | otherwise = zipWith (<>) ds (replicate n d ++ [pure empty])   where-    n = length ds - 1+    ds = Fold.toList ts+    n  = length ds - 1  --------------------------------------------------------------------------- -- * The PrettyTCM class@@ -140,6 +152,12 @@   , Semigroup (m Doc)   ) +-- This instance is to satify the constraints of superclass MonadPretty:+-- | This instance is more specific than a generic instance+-- @Semigroup a => Semigroup (TCM a)@.+instance {-# OVERLAPPING #-} Semigroup (TCM Doc)         where (<>) = liftA2 (<>)++ class PrettyTCM a where   prettyTCM :: MonadPretty m => a -> m Doc @@ -147,6 +165,7 @@ prettyTCMCtx :: (PrettyTCM a, MonadPretty m) => Precedence -> a -> m Doc prettyTCMCtx p = withContextPrecedence p . prettyTCM +instance {-# OVERLAPPING #-} PrettyTCM String where prettyTCM = text instance PrettyTCM Bool        where prettyTCM = pretty instance PrettyTCM C.Name      where prettyTCM = pretty instance PrettyTCM C.QName     where prettyTCM = pretty@@ -162,9 +181,12 @@ instance PrettyTCM a => PrettyTCM (Closure a) where   prettyTCM cl = enterClosure cl prettyTCM -instance PrettyTCM a => PrettyTCM [a] where+instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM [a] where   prettyTCM = prettyList . map prettyTCM +instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM (Maybe a) where+  prettyTCM = maybe empty prettyTCM+ instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where   prettyTCM (a, b) = parens $ prettyTCM a <> comma <> prettyTCM b @@ -172,23 +194,33 @@   prettyTCM (a, b, c) = parens $     prettyTCM a <> comma <> prettyTCM b <> comma <> prettyTCM c -instance PrettyTCM Term         where prettyTCM = prettyA <=< reify-instance PrettyTCM Type         where prettyTCM = prettyA <=< reify-instance PrettyTCM Sort         where prettyTCM = prettyA <=< reify-instance PrettyTCM DisplayTerm  where prettyTCM = prettyA <=< reify-instance PrettyTCM NamedClause  where prettyTCM = prettyA <=< reify-instance PrettyTCM (QNamed Clause) where prettyTCM = prettyA <=< reify-instance PrettyTCM Level        where prettyTCM = prettyA <=< reify . Level-instance PrettyTCM Permutation  where prettyTCM = text . show-instance PrettyTCM Polarity     where prettyTCM = text . show-instance PrettyTCM IsForced     where prettyTCM = text . show+instance PrettyTCM Term               where prettyTCM = prettyA <=< reify+instance PrettyTCM Type               where prettyTCM = prettyA <=< reify+instance PrettyTCM Sort               where prettyTCM = prettyA <=< reify+instance PrettyTCM DisplayTerm        where prettyTCM = prettyA <=< reify+instance PrettyTCM NamedClause        where prettyTCM = prettyA <=< reify+instance PrettyTCM (QNamed Clause)    where prettyTCM = prettyA <=< reify+instance PrettyTCM Level              where prettyTCM = prettyA <=< reify . Level+instance PrettyTCM (Named_ Term)      where prettyTCM = prettyA <=< reify+instance PrettyTCM (Arg Term)         where prettyTCM = prettyA <=< reify+instance PrettyTCM (Arg Type)         where prettyTCM = prettyA <=< reify+instance PrettyTCM (Arg Bool)         where prettyTCM = prettyA <=< reify+instance PrettyTCM (Arg A.Expr)       where prettyTCM = prettyA <=< reify+instance PrettyTCM (NamedArg A.Expr)  where prettyTCM = prettyA <=< reify+instance PrettyTCM (NamedArg Term)    where prettyTCM = prettyA <=< reify+instance PrettyTCM (Dom Type)         where prettyTCM = prettyA <=< reify+instance PrettyTCM (Dom (Name, Type)) where prettyTCM = prettyA <=< reify +instance PrettyTCM Permutation where prettyTCM = text . show+instance PrettyTCM Polarity    where prettyTCM = text . show+instance PrettyTCM IsForced    where prettyTCM = text . show+ prettyR-  :: (R.ToAbstract r a, PrettyTCM a, MonadPretty m, MonadError TCErr m)+  :: (R.ToAbstract r, PrettyTCM (R.AbsOfRef r), MonadPretty m, MonadError TCErr m)   => r -> m Doc prettyR = prettyTCM <=< toAbstractWithoutImplicit -instance (Pretty a, PrettyTCM a, Subst a a) => PrettyTCM (Substitution' a) where+instance (Pretty a, PrettyTCM a, EndoSubst a) => PrettyTCM (Substitution' a) where   prettyTCM IdS        = "idS"   prettyTCM (Wk m IdS) = "wkS" <+> pretty m   prettyTCM (EmptyS _) = "emptyS"@@ -215,21 +247,12 @@   prettyTCM (Blocked x a) = ("[" <+> prettyTCM a <+> "]") <> text (P.prettyShow x)   prettyTCM (NotBlocked _ x) = prettyTCM x -instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Named_ a) where-  prettyTCM x = prettyA =<< reify x--instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Arg a) where-  prettyTCM x = prettyA =<< reify x--instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Dom a) where-  prettyTCM x = prettyA =<< reify x- instance (PrettyTCM k, PrettyTCM v) => PrettyTCM (Map k v) where   prettyTCM m = "Map" <> braces (sep $ punctuate comma     [ hang (prettyTCM k <+> "=") 2 (prettyTCM v) | (k, v) <- Map.toList m ]) -instance {-# OVERLAPPING #-} PrettyTCM ArgName where-  prettyTCM = text . P.prettyShow+-- instance {-# OVERLAPPING #-} PrettyTCM ArgName where+--   prettyTCM = text . P.prettyShow  -- instance (Reify a e, ToConcrete e c, P.Pretty c, PrettyTCM a) => PrettyTCM (Elim' a) where instance PrettyTCM Elim where@@ -261,90 +284,11 @@     , prettyTCM (getRelevance mod)     ] -instance PrettyTCM ProblemConstraint where-  prettyTCM (PConstr pids c) = prettyTCM c <?> prPids (Set.toList pids)-    where-      prPids []    = empty-      prPids [pid] = parens $ "problem" <+> prettyTCM pid-      prPids pids  = parens $ "problems" <+> fsep (punctuate "," $ map prettyTCM pids)--instance PrettyTCM Constraint where-    prettyTCM c = case c of-        ValueCmp cmp ty s t -> prettyCmp (prettyTCM cmp) s t <?> prettyTCM ty-        ValueCmpOnFace cmp p ty s t ->-            sep [ prettyTCM p <+> "|"-                , prettyCmp (prettyTCM cmp) s t ]-            <?> (":" <+> prettyTCMCtx TopCtx ty)-        ElimCmp cmps fs t v us vs -> prettyCmp "~~" us vs   <?> (":" <+> prettyTCMCtx TopCtx t)-        LevelCmp cmp a b         -> prettyCmp (prettyTCM cmp) a b-        TelCmp a b cmp tela telb -> prettyCmp (prettyTCM cmp) tela telb-        SortCmp cmp s1 s2        -> prettyCmp (prettyTCM cmp) s1 s2-        Guarded c pid            -> prettyTCM c <?> (parens $ "blocked by problem" <+> prettyTCM pid)-        UnBlock m   -> do-            -- BlockedConst t <- mvInstantiation <$> lookupMeta m-            mi <- mvInstantiation <$> lookupMeta m-            case mi of-              BlockedConst t -> prettyCmp ":=" m t-              PostponedTypeCheckingProblem cl _ -> enterClosure cl $ \p ->-                prettyCmp ":=" m p-              Open{}  -> __IMPOSSIBLE__-              OpenInstance{} -> __IMPOSSIBLE__-              InstV{} -> empty-              -- Andreas, 2017-01-11, issue #2637:-              -- The size solver instantiates some metas with infinity-              -- without cleaning up the UnBlock constraints.-              -- Thus, this case is not IMPOSSIBLE.-              ---              -- InstV args t -> do-              --   reportS "impossible" 10-              --     [ "UnBlock meta " ++ show m ++ " surprisingly has InstV instantiation:"-              --     , show m ++ show args ++ " := " ++ show t-              --     ]-              --   __IMPOSSIBLE__-        FindInstance m mb mcands -> do-            t <- getMetaType m-            sep [ "Resolve instance argument" <+> blk-                    <?> prettyCmp ":" m t-                , cands-                ]-          where-            blk = case mb of-                    Nothing -> empty-                    Just b  -> parens $ "blocked on" <+> pretty b-            cands =-              case mcands of-                Nothing -> "No candidates yet"-                Just cnds ->-                  hang "Candidates" 2 $-                    vcat [ hang (overlap c <+> prettyTCM (candidateTerm c) <+> ":") 2 $-                            prettyTCM (candidateType c) | c <- cnds ]-              where overlap c | candidateOverlappable c = "overlap"-                              | otherwise               = empty-        IsEmpty r t ->-            "Is empty:" <?> prettyTCMCtx TopCtx t-        CheckSizeLtSat t ->-            "Is not empty type of sizes:" <?> prettyTCMCtx TopCtx t-        CheckFunDef d i q cs -> do-            t <- defType <$> getConstInfo q-            "Check definition of" <+> prettyTCM q <+> ":" <+> prettyTCM t-        HasBiggerSort a -> "Has bigger sort:" <+> prettyTCM a-        HasPTSRule a b -> "Has PTS rule:" <+> case b of-          NoAbs _ b -> prettyTCM (a,b)-          Abs x b   -> "(" <> (prettyTCM a <+> "," <+> addContext x (prettyTCM b)) <> ")"-        UnquoteTactic _ v _ _ -> do-          e <- reify v-          prettyTCM (A.App A.defaultAppInfo_ (A.Unquote A.exprNoRange) (defaultNamedArg e))-        CheckMetaInst x -> do-          m <- lookupMeta x-          case mvJudgement m of-            HasType{ jMetaType = t } -> prettyTCM x <+> ":" <+> prettyTCM t-            IsSort{} -> prettyTCM x <+> "is a sort"--      where-        prettyCmp-          :: (PrettyTCM a, PrettyTCM b, MonadPretty m)-          => m Doc -> a -> b -> m Doc-        prettyCmp cmp x y = prettyTCMCtx TopCtx x <?> (cmp <+> prettyTCMCtx TopCtx y)+instance PrettyTCM Blocker where+  prettyTCM (UnblockOnAll us) = "all" <> parens (fsep $ punctuate "," $ map prettyTCM $ Set.toList us)+  prettyTCM (UnblockOnAny us) = "any" <> parens (fsep $ punctuate "," $ map prettyTCM $ Set.toList us)+  prettyTCM (UnblockOnMeta m) = prettyTCM m+  prettyTCM (UnblockOnProblem p) = "problem" <+> pretty p  instance PrettyTCM CompareAs where   prettyTCM (AsTermsOf a) = ":" <+> prettyTCMCtx TopCtx a@@ -354,20 +298,20 @@ instance PrettyTCM TypeCheckingProblem where   prettyTCM (CheckExpr cmp e a) =     sep [ prettyA e <+> ":?", prettyTCM a ]-  prettyTCM (CheckArgs _ _ es t0 t1 _) =+  prettyTCM (CheckArgs _ _ _ es t0 t1 _) =     sep [ parens $ "_ :" <+> prettyTCM t0         , nest 2 $ prettyList $ map prettyA es         , nest 2 $ ":?" <+> prettyTCM t1 ]-  prettyTCM (CheckProjAppToKnownPrincipalArg cmp e _ _ _ t _ _ _) = prettyTCM (CheckExpr cmp e t)+  prettyTCM (CheckProjAppToKnownPrincipalArg cmp e _ _ _ t _ _ _ _) = prettyTCM (CheckExpr cmp e t)   prettyTCM (CheckLambda cmp (Arg ai (xs, mt)) e t) =-    sep [ return CP.lambda <+>+    sep [ pure CP.lambda <+>           (CP.prettyRelevance ai .            CP.prettyHiding ai (if isNothing mt && length xs == 1 then id                                else P.parens) <$> do             fsep $-              map prettyTCM xs +++              map prettyTCM (List1.toList xs) ++               caseMaybe mt [] (\ a -> [":", prettyTCM a])) <+>-          return CP.arrow <+>+          pure CP.arrow <+>           prettyTCM e <+>           ":?"         , prettyTCM t@@ -388,14 +332,16 @@ instance PrettyTCM ModuleName where   prettyTCM x = P.pretty <$> abstractToConcrete_ x +instance PrettyTCM AbstractName where+  prettyTCM = prettyTCM . anameName+ instance PrettyTCM ConHead where   prettyTCM = prettyTCM . conName  instance PrettyTCM Telescope where-  prettyTCM tel = P.fsep . map P.pretty <$> (do+  prettyTCM tel = P.fsep . map P.pretty <$> do       tel <- reify tel       runAbsToCon $ bindToConcrete tel return-    )  newtype PrettyContext = PrettyContext Context @@ -406,26 +352,29 @@   prettyTCM = prettyTCM . var . dbPatVarIndex  instance PrettyTCM a => PrettyTCM (Pattern' a) where+  prettyTCM :: forall m. MonadPretty m => Pattern' a -> m Doc   prettyTCM (IApplyP _ _ _ x)    = prettyTCM x   prettyTCM (VarP _ x)    = prettyTCM x   prettyTCM (DotP _ t)    = ".(" <> prettyTCM t <> ")"   prettyTCM (DefP o q ps) = parens $         prettyTCM q <+> fsep (map (prettyTCM . namedArg) ps)-  prettyTCM (ConP c i ps) = (if b then braces else parens) $ prTy $+  prettyTCM (ConP c i ps) = -- (if b then braces else parens) $ prTy $+        parens $         prettyTCM c <+> fsep (map (prettyTCM . namedArg) ps)-        where+      where+        -- NONE OF THESE BINDINGS IS USED AT THE MOMENT:         b = conPRecord i && patOrigin (conPInfo i) /= PatOCon-        showRec :: MonadPretty m => m Doc+        showRec :: m Doc -- Defined, but currently not used         showRec = sep           [ "record"           , bracesAndSemicolons <$> zipWithM showField (conFields c) ps           ]-        showField :: MonadPretty m => Arg QName -> NamedArg (Pattern' a) -> m Doc+        showField :: Arg QName -> NamedArg (Pattern' a) -> m Doc -- NB:: Defined but not used         showField (Arg ai x) p =           sep [ prettyTCM (A.qnameName x) <+> "=" , nest 2 $ prettyTCM $ namedArg p ]-        showCon :: MonadPretty m => m Doc+        showCon :: m Doc -- NB:: Defined but not used         showCon = parens $ prTy $ prettyTCM c <+> fsep (map (prettyTCM . namedArg) ps)-        prTy d = d -- caseMaybe (conPType i) d $ \ t -> d  <+> ":" <+> prettyTCM t+        prTy d = caseMaybe (conPType i) d $ \ t -> d  <+> ":" <+> prettyTCM t   prettyTCM (LitP _ l)    = text (P.prettyShow l)   prettyTCM (ProjP _ q)   = text ("." ++ P.prettyShow q) @@ -447,10 +396,10 @@     prettyTCM f <+> fsep (map prettyTCM es)   prettyTCM (PLam i u)  = parens $     text ("λ " ++ absName u ++ " →") <+>-    (addContext (absName u) $ prettyTCM $ absBody u)+    addContext (absName u) (prettyTCM $ absBody u)   prettyTCM (PPi a b)   = parens $     text ("(" ++ absName b ++ " :") <+> (prettyTCM (unDom a) <> ") →") <+>-    (addContext (absName b) $ prettyTCM $ unAbs b)+    addContext (absName b) (prettyTCM $ unAbs b)   prettyTCM (PSort s)        = prettyTCM s   prettyTCM (PBoundVar i []) = prettyTCM (var i)   prettyTCM (PBoundVar i es) = parens $ prettyTCM (var i) <+> fsep (map prettyTCM es)@@ -463,8 +412,9 @@   prettyTCM = \case     PType l   -> parens $ "Set" <+> prettyTCM l     PProp l   -> parens $ "Prop" <+> prettyTCM l-    PInf      -> prettyTCM (Inf :: Sort)+    PInf f n  -> prettyTCM (Inf f n :: Sort)     PSizeUniv -> prettyTCM (SizeUniv :: Sort)+    PLockUniv -> prettyTCM (LockUniv :: Sort)  instance PrettyTCM (Elim' NLPat) where   prettyTCM (IApply x y v) = prettyTCM v@@ -475,7 +425,7 @@   prettyTCM = prettyTCM . unEl  instance PrettyTCM RewriteRule where-  prettyTCM (RewriteRule q gamma f ps rhs b) = fsep+  prettyTCM (RewriteRule q gamma f ps rhs b c) = fsep     [ prettyTCM q     , prettyTCM gamma <+> " |- "     , addContext gamma $ sep@@ -493,18 +443,28 @@ -- | Pairing something with a node (for printing only). data WithNode n a = WithNode n a -instance PrettyTCM n => PrettyTCM (WithNode n Occurrence) where-  prettyTCM (WithNode n o) = prettyTCM o <+> prettyTCM n+-- | Pretty-print something paired with a (printable) node.+-- | This intermediate typeclass exists to avoid UndecidableInstances.+class PrettyTCMWithNode a where+  prettyTCMWithNode :: (PrettyTCM n, MonadPretty m) => WithNode n a -> m Doc -instance (PrettyTCM n, PrettyTCM (WithNode n e)) => PrettyTCM (Graph n e) where+instance PrettyTCMWithNode Occurrence where+  prettyTCMWithNode (WithNode n o) = prettyTCM o <+> prettyTCM n++instance (PrettyTCM n, PrettyTCMWithNode e) => PrettyTCM (Graph n e) where   prettyTCM g = vcat $ map pr $ Map.assocs $ Graph.graph g     where       pr (n, es) = sep         [ prettyTCM n-        , nest 2 $ vcat $ map (prettyTCM . uncurry WithNode) $ Map.assocs es+        , nest 2 $ vcat $ map (prettyTCMWithNode . uncurry WithNode) $ Map.assocs es         ]  instance PrettyTCM SplitTag where   prettyTCM (SplitCon c)  = prettyTCM c   prettyTCM (SplitLit l)  = prettyTCM l   prettyTCM SplitCatchall = return underscore++instance PrettyTCM Candidate where+  prettyTCM c = case candidateKind c of+    (GlobalCandidate q) -> prettyTCM q+    LocalCandidate      -> prettyTCM $ candidateTerm c

src/full/Agda/TypeChecking/Pretty.hs-boot view

@@ -1,43 +1,42 @@  module Agda.TypeChecking.Pretty where +import Control.Monad.Reader (ReaderT)+import Control.Monad.State  (StateT)+ import Data.String (IsString) import Data.Semigroup (Semigroup)  import Agda.Syntax.Common (NameId) import Agda.Syntax.Internal -- import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin import {-# SOURCE #-} Agda.TypeChecking.Monad.Context (MonadAddContext) import Agda.TypeChecking.Monad.Debug (MonadDebug) import {-# SOURCE #-} Agda.TypeChecking.Monad.MetaVars (MonadInteractionPoints)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Pure (PureTCM) import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)+ import Agda.Utils.Null (Null) import Agda.Utils.Pretty (Doc) import qualified Agda.Utils.Pretty as P -text                  :: Monad m => String -> m Doc-sep, fsep, hsep, vcat :: Monad m => [m Doc] -> m Doc++text                  :: Applicative m => String -> m Doc+sep, fsep, hsep, vcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc hang                  :: Applicative m => m Doc -> Int -> m Doc -> m Doc ($$), (<+>), (<?>)    :: Applicative m => m Doc -> m Doc -> m Doc nest                  :: Functor m => Int -> m Doc -> m Doc-pretty                :: (Monad m, P.Pretty a) => a -> m Doc-prettyList_           :: (Monad m, Semigroup (m Doc)) => [m Doc] -> m Doc+pretty                :: (Applicative m, P.Pretty a) => a -> m Doc+prettyList_           :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc  -- Inlining definitions of MonadReify and MonadAbsToCon to avoid -- having to import them type MonadPretty m =-  ( ( MonadReduce m-    , MonadAddContext m+  ( ( PureTCM m     , MonadInteractionPoints m     , MonadFresh NameId m-    , HasConstInfo m-    , HasOptions m-    , HasBuiltins m-    , MonadDebug m     )   , ( MonadTCEnv m     , ReadTCState m@@ -50,6 +49,11 @@   , Null (m Doc)   , Semigroup (m Doc)   )++-- This instance is to satify the constraints of superclass MonadPretty:+-- This instance is more specific than a generic instance+-- @Semigroup a => Semigroup (TCM a)@.+instance {-# OVERLAPPING #-} Semigroup (TCM Doc)  class PrettyTCM a where   prettyTCM :: MonadPretty m => a -> m Doc

src/full/Agda/TypeChecking/Pretty/Call.hs view

@@ -63,6 +63,14 @@       pwords "when checking that the pattern"       ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t] +    CheckPatternLinearityType x -> fsep $+      pwords "when checking that all occurrences of pattern variable"+      ++ [pretty x] ++ pwords "have the same type"++    CheckPatternLinearityValue x -> fsep $+      pwords "when checking that all occurrences of pattern variable"+      ++ [pretty x] ++ pwords "have the same value"+     CheckLetBinding b -> fsep $       pwords "when checking the let binding" ++ [prettyA b] @@ -121,7 +129,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 ->@@ -179,7 +187,7 @@      CheckSectionApplication _ m1 modapp -> fsep $       pwords "when checking the module application" ++-      [prettyA $ A.Apply info m1 modapp initCopyInfo defaultImportDir]+      [prettyA $ A.Apply info m1 modapp initCopyInfo empty]       where       info = A.ModuleInfo noRange noRange Nothing Nothing Nothing

+ src/full/Agda/TypeChecking/Pretty/Constraint.hs view

@@ -0,0 +1,143 @@++module Agda.TypeChecking.Pretty.Constraint where++import Prelude hiding (null)++import qualified Data.Set as Set+import qualified Data.List as List+import Data.Function++import Agda.Syntax.Common+import Agda.Syntax.Position+import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Info     as A+import Agda.Syntax.Fixity+import Agda.Syntax.Translation.InternalToAbstract+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Errors+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Utils.Null+import qualified Agda.Utils.Pretty as P+import Agda.Utils.Impossible++prettyConstraint :: MonadPretty m => ProblemConstraint -> m Doc+prettyConstraint c = f (locallyTCState stInstantiateBlocking (const True) $ prettyTCM c)+  where+    r   = getRange c+    f :: MonadPretty m => m Doc -> m Doc+    f d = if null $ P.pretty r+          then d+          else d $$ nest 4 ("[ at" <+> prettyTCM r <+> "]")++interestingConstraint :: ProblemConstraint -> Bool+interestingConstraint pc = go $ clValue (theConstraint pc)+  where+    go UnBlock{} = False+    go _         = True++prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]+prettyInterestingConstraints cs = mapM (prettyConstraint . stripPids) $ List.sortBy (compare `on` isBlocked) cs'+  where+    isBlocked = not . null . allBlockingProblems . constraintUnblocker+    cs' = filter interestingConstraint cs+    interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs'+    stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c++instance PrettyTCM ProblemConstraint where+  prettyTCM (PConstr pids unblock c) = prettyTCM c <?> parensNonEmpty (sep [blockedOn unblock, prPids (Set.toList pids)])+    where+      prPids []    = empty+      prPids [pid] = "belongs to problem" <+> prettyTCM pid+      prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids)++      comma | null pids = empty+            | otherwise = ","++      blockedOn (UnblockOnAll bs) | Set.null bs = empty+      blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma+      blockedOn u = "blocked on" <+> (prettyTCM u <> comma)++instance PrettyTCM Constraint where+    prettyTCM = \case+        ValueCmp cmp ty s t -> prettyCmp (prettyTCM cmp) s t <?> prettyTCM ty+        ValueCmpOnFace cmp p ty s t ->+            sep [ prettyTCM p <+> "|"+                , prettyCmp (prettyTCM cmp) s t ]+            <?> (":" <+> prettyTCMCtx TopCtx ty)+        ElimCmp cmps fs t v us vs -> prettyCmp "~~" us vs   <?> (":" <+> prettyTCMCtx TopCtx t)+        LevelCmp cmp a b         -> prettyCmp (prettyTCM cmp) a b+        SortCmp cmp s1 s2        -> prettyCmp (prettyTCM cmp) s1 s2+        UnBlock m   -> do+            -- BlockedConst t <- mvInstantiation <$> lookupMeta m+            mi <- mvInstantiation <$> lookupMeta m+            case mi of+              BlockedConst t -> prettyCmp ":=" m t+              PostponedTypeCheckingProblem cl -> enterClosure cl $ \p ->+                prettyCmp ":=" m p+              Open{}  -> __IMPOSSIBLE__+              OpenInstance{} -> __IMPOSSIBLE__+              InstV{} -> empty+              -- Andreas, 2017-01-11, issue #2637:+              -- The size solver instantiates some metas with infinity+              -- without cleaning up the UnBlock constraints.+              -- Thus, this case is not IMPOSSIBLE.+              --+              -- InstV args t -> do+              --   reportS "impossible" 10+              --     [ "UnBlock meta " ++ show m ++ " surprisingly has InstV instantiation:"+              --     , show m ++ show args ++ " := " ++ show t+              --     ]+              --   __IMPOSSIBLE__+        FindInstance m mcands -> do+            t <- getMetaTypeInContext m+            TelV tel _ <- telViewUpTo' (-1) notVisible t+            sep [ "Resolve instance argument" <?> prettyCmp ":" m t+                  -- #4071: Non-visible arguments to the meta are in scope of the candidates add+                  --        those here to not get out of scope deBruijn indices when printing+                  --        unsolved constraints.+                , addContext tel cands+                ]+          where+            cands =+              case mcands of+                Nothing -> "No candidates yet"+                Just cnds ->+                  hang "Candidates" 2 $ vcat+                    [ hang (overlap c <+> prettyTCM c <+> ":") 2 $+                            prettyTCM (candidateType c) | c <- cnds ]+              where overlap c | candidateOverlappable c = "overlap"+                              | otherwise               = empty+        IsEmpty r t ->+            "Is empty:" <?> prettyTCMCtx TopCtx t+        CheckSizeLtSat t ->+            "Is not empty type of sizes:" <?> prettyTCMCtx TopCtx t+        CheckFunDef d i q cs err -> do+            t <- defType <$> getConstInfo q+            vcat [ "Check definition of" <+> prettyTCM q <+> ":" <+> prettyTCM t+                 , nest 2 $ "stuck because" <?> prettyTCM err ]+        HasBiggerSort a -> "Has bigger sort:" <+> prettyTCM a+        HasPTSRule a b -> "Has PTS rule:" <+> case b of+          NoAbs _ b -> prettyTCM (a,b)+          Abs x b   -> "(" <> (prettyTCM a <+> "," <+> addContext x (prettyTCM b)) <> ")"+        UnquoteTactic v _ _ -> do+          e <- reify v+          prettyTCM (A.App A.defaultAppInfo_ (A.Unquote A.exprNoRange) (defaultNamedArg e))+        CheckMetaInst x -> do+          m <- lookupMeta x+          case mvJudgement m of+            HasType{ jMetaType = t } -> prettyTCM x <+> ":" <+> prettyTCM t+            IsSort{} -> prettyTCM x <+> "is a sort"+        CheckLockedVars t ty lk lk_ty -> do+          "Lock" <+> prettyTCM lk <+> "|-" <+> prettyTCMCtx TopCtx t <+> ":" <+> prettyTCM ty+        UsableAtModality mod t -> "Is usable at" <+> prettyTCM mod <+> ":" <+> prettyTCM t++      where+        prettyCmp+          :: (PrettyTCM a, PrettyTCM b, MonadPretty m)+          => m Doc -> a -> b -> m Doc+        prettyCmp cmp x y = prettyTCMCtx TopCtx x <?> (cmp <+> prettyTCMCtx TopCtx y)

+ src/full/Agda/TypeChecking/Pretty/Constraint.hs-boot view

@@ -0,0 +1,9 @@++module Agda.TypeChecking.Pretty.Constraint where++import Text.PrettyPrint (Doc)+import Agda.TypeChecking.Pretty (MonadPretty)+import Agda.TypeChecking.Monad.Base (ProblemConstraint)++prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]+interestingConstraint        :: ProblemConstraint -> Bool

src/full/Agda/TypeChecking/Pretty/Warning.hs view

@@ -3,70 +3,59 @@  import Prelude hiding ( null ) +import Control.Monad ( guard )++-- Control.Monad.Fail import is redundant since GHC 8.8.1+import Control.Monad.Fail ( MonadFail )+ import Data.Char ( toLower ) import Data.Function+import Data.Maybe+ import qualified Data.Set as Set+import Data.Set (Set)+ import qualified Data.List as List+import qualified Data.Text as T  import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.MetaVars import Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.State ( getScope )+import Agda.TypeChecking.Monad ( localTCState ) import Agda.TypeChecking.Positivity () --instance only import Agda.TypeChecking.Pretty import Agda.TypeChecking.Pretty.Call+import {-# SOURCE #-} Agda.TypeChecking.Pretty.Constraint (prettyInterestingConstraints, interestingConstraint)+import Agda.TypeChecking.Warnings (MonadWarning, isUnsolvedWarning, onlyShowIfUnsolved, classifyWarning, WhichWarnings(..), warning_)+import Agda.TypeChecking.Monad.Constraints (getAllConstraints) +import Agda.Syntax.Common ( ImportedName'(..), fromImportedName, partitionImportedNames ) import Agda.Syntax.Position import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Scope.Base ( concreteNamesInScope, NameOrModule(..) ) import Agda.Syntax.Internal import Agda.Syntax.Translation.InternalToAbstract -import {-# SOURCE #-} Agda.Interaction.Imports import Agda.Interaction.Options import Agda.Interaction.Options.Warnings  import Agda.Utils.Lens import Agda.Utils.List ( editDistance )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null+import Agda.Utils.Pretty ( Pretty, prettyShow ) import qualified Agda.Utils.Pretty as P  instance PrettyTCM TCWarning where-  prettyTCM = return . tcWarningPrintedWarning--instance PrettyTCM Warning where-  prettyTCM = prettyWarning--prettyConstraint :: MonadPretty m => ProblemConstraint -> m Doc-prettyConstraint c = f (locallyTCState stInstantiateBlocking (const True) $ prettyTCM c)-  where-    r   = getRange c-    f :: MonadPretty m => m Doc -> m Doc-    f d = if null $ P.pretty r-          then d-          else d $$ nest 4 ("[ at" <+> prettyTCM r <+> "]")--interestingConstraint :: ProblemConstraint -> Bool-interestingConstraint pc = go $ clValue (theConstraint pc)-  where-    go UnBlock{}     = False-    go (Guarded c _) = go c-    go _             = True--prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]-prettyInterestingConstraints cs = mapM (prettyConstraint . stripPids) $ List.sortBy (compare `on` isBlocked) cs'-  where-    isBlocked = not . null . blocking . clValue . theConstraint-    cs' = filter interestingConstraint cs-    interestingPids = Set.fromList $ concatMap (blocking . clValue . theConstraint) cs'-    stripPids (PConstr pids c) = PConstr (Set.intersection pids interestingPids) c-    blocking (Guarded c pid) = pid : blocking c-    blocking _               = []+  prettyTCM w@(TCWarning loc _ _ _ _) = do+    reportSLn "warning" 2 $ "Warning raised at " ++ prettyShow loc+    pure $ tcWarningPrintedWarning w -{-# SPECIALIZE prettyWarning :: Warning -> TCM Doc #-} prettyWarning :: MonadPretty m => Warning -> m Doc-prettyWarning wng = case wng of+prettyWarning = \case      UnsolvedMetaVariables ms  ->       fsep ( pwords "Unsolved metas at the following locations:" )@@ -88,11 +77,11 @@     TerminationIssue because -> do       dropTopLevel <- topLevelModuleDropper       fwords "Termination checking failed for the following functions:"-        $$ (nest 2 $ fsep $ punctuate comma $+        $$ nest 2 (fsep $ punctuate comma $              map (pretty . dropTopLevel) $                concatMap termErrFunctions because)         $$ fwords "Problematic calls:"-        $$ (nest 2 $ fmap (P.vcat . List.nub) $+        $$ nest 2 (fmap (P.vcat . List.nub) $               mapM prettyTCM $ List.sortBy (compare `on` callInfoRange) $               concatMap termErrCalls because) @@ -110,9 +99,9 @@           empty { clauseTel = tel, namedClausePats = ps }      CoverageNoExactSplit f cs -> vcat $-      [ fsep $ pwords "Exact splitting is enabled, but the following" ++ pwords (P.singPlural cs "clause" "clauses") ++-               pwords "could not be preserved as definitional equalities in the translation to a case tree:"-      ] +++      fsep (pwords "Exact splitting is enabled, but the following" ++ pwords (P.singPlural cs "clause" "clauses") +++            pwords "could not be preserved as definitional equalities in the translation to a case tree:"+           ) :       map (nest 2 . prettyTCM . NamedClause f True) cs      NotStrictlyPositive d ocs -> fsep $@@ -135,6 +124,8 @@      EmptyRewritePragma -> fsep . pwords $ "Empty REWRITE pragma" +    EmptyWhere         -> fsep . pwords $ "Empty `where' block (ignored)"+     IllformedAsClause s -> fsep . pwords $       "`as' must be followed by an identifier" ++ s @@ -144,8 +135,16 @@       , map prettyTCM xs       ] +    UselessPatternDeclarationForRecord s -> fwords $ unwords+      [ "`pattern' attribute ignored for", s, "record" ]+     UselessPublic -> fwords $ "Keyword `public' is ignored here" +    UselessHiding xs -> fsep $ concat+      [ pwords "Ignoring names in `hiding' directive:"+      , punctuate "," $ map pretty xs+      ]+     UselessInline q -> fsep $       pwords "It is pointless for INLINE'd function" ++ [prettyTCM q] ++       pwords "to have a separate Haskell definition"@@ -172,10 +171,18 @@              pwords "also mean that you need to increase the maximum depth using the flag" ++              pwords "--inversion-max-depth=N" +    NoGuardednessFlag q ->+      fsep $ [ prettyTCM q ] ++ pwords "is declared coinductive, but option" +++             pwords "--guardedness is not enabled. Coinductive functions on" +++             pwords "this type will likely be rejected by the termination" +++             pwords "checker unless this flag is enabled."+     GenericWarning d -> return d      GenericNonFatalError d -> return d +    GenericUseless _r d -> return d+     SafeFlagPostulate e -> fsep $       pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag" @@ -221,12 +228,22 @@      NicifierIssue w -> sayWhere (getRange w) $ pretty w -    UserWarning str -> text str+    UserWarning str -> text (T.unpack str) -    ModuleDoesntExport m xs -> fsep $-      pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++-      punctuate comma (map pretty xs)+    ModuleDoesntExport m names modules xs -> vcat+      [ fsep $ pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:"+      , prettyNotInScopeNames False (suggestion names)   ys+      , prettyNotInScopeNames False (suggestion modules) ms+      ]+      where+      ys, ms :: [C.ImportedName]+      ys            = map ImportedName   ys0+      ms            = map ImportedModule ms0+      (ys0, ms0)    = partitionImportedNames xs+      suggestion zs = maybe empty parens . didYouMean (map C.QName zs) fromImportedName +    DuplicateUsing xs -> fsep $ pwords "Duplicates in `using` directive:" ++ map pretty (List1.toList xs)+     FixityInRenamingModule _rs -> fsep $ pwords "Modules do not have fixity"      LibraryWarning lw -> pretty lw@@ -240,55 +257,151 @@       [pretty o] ++ pwords "flag from a module which does."      RewriteNonConfluent lhs rhs1 rhs2 err -> fsep-      [ "Confluence check failed:"+      [ "Local confluence check failed:"       , prettyTCM lhs , "reduces to both"       , prettyTCM rhs1 , "and" , prettyTCM rhs2       , "which are not equal because"       , return err       ] -    RewriteMaybeNonConfluent lhs1 lhs2 cs -> do-      vcat $-        [ fsep-           [ "Couldn't determine overlap between left-hand sides"-           , prettyTCM lhs1 , "and" , prettyTCM lhs2-           , "because of unsolved constraints:"-           ]-        ] ++ map (nest 2 . return) cs+    RewriteMaybeNonConfluent lhs1 lhs2 cs -> vcat $ concat+      [ [ fsep $ concat+          [ pwords "Couldn't determine overlap between left-hand sides"+          , [ prettyTCM lhs1 , text "and" , prettyTCM lhs2 ]+          , pwords "because of unsolved constraints:"+          ]+        ]+      , map (nest 2 . return) cs+      ] -    PragmaCompileErased bn qn -> fsep $-      pwords "The backend" ++ [text bn] ++ pwords "erases" ++ [prettyTCM qn]-      ++ pwords "so the COMPILE pragma will be ignored."+    RewriteAmbiguousRules lhs rhs1 rhs2 -> vcat+      [ ( fsep $ concat+          [ pwords "Global confluence check failed:" , [prettyTCM lhs]+          , pwords "can be rewritten to either" , [prettyTCM rhs1]+          , pwords "or" , [prettyTCM rhs2 <> "."]+          ])+      , fsep $ concat+        [ pwords "Possible fix: add a rewrite rule with left-hand side"+        , [prettyTCM lhs] , pwords "to resolve the ambiguity."+        ]+      ] -    NotInScopeW xs -> do-      inscope <- Set.toList . concreteNamesInScope <$> getScope-      fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map (name inscope) xs)+    RewriteMissingRule u v rhou -> vcat+      [ fsep $ concat+        [ pwords "Global confluence check failed:" , [prettyTCM u]+        , pwords "unfolds to" , [prettyTCM v] , pwords "which should further unfold to"+        , [prettyTCM rhou] , pwords "but it does not."+        ]+      , fsep $ concat+        [ pwords "Possible fix: add a rule to rewrite"+        , [ prettyTCM v , "to" , prettyTCM rhou ]+        ]+      ]++    PragmaCompileErased bn qn -> fsep $ concat+      [ pwords "The backend"+      , [ text bn+        , "erases"+        , prettyTCM qn+        ]+      , pwords "so the COMPILE pragma will be ignored."+      ]++    NotInScopeW xs -> vcat+      [ fsep $ pwords "Not in scope:"+      , do+        inscope <- Set.toList . concreteNamesInScope <$> getScope+        prettyNotInScopeNames True (suggestion inscope) xs+      ]       where-      name inscope x =-        fsep [ pretty x-             , "at" <+> prettyTCM (getRange x)-             , suggestion inscope x-             ]-      suggestion inscope x = nest 2 $ par $-        [ "did you forget space around the ':'?"  | ':' `elem` s ] ++-        [ "did you forget space around the '->'?" | List.isInfixOf "->" s ] ++-        [ sep [ "did you mean"-              , nest 2 $ vcat (punctuate " or"-                       $ map (\ y -> text $ "'" ++ y ++ "'") ys)-              <> "?" ]-          | not $ null ys ]+      suggestion inscope x = nest 2 $ par $ concat+        [ [ "did you forget space around the ':'?"  | ':' `elem` s ]+        , [ "did you forget space around the '->'?" | "->" `List.isInfixOf` s ]+        , maybeToList $ didYouMean inscope C.unqualify x+        ]         where-          s = P.prettyShow x-          par []  = empty-          par [d] = parens d-          par ds  = parens $ vcat ds+        par []  = empty+        par [d] = parens d+        par ds  = parens $ vcat ds+        s = P.prettyShow x -          strip x = map toLower $ filter (/= '_') $ P.prettyShow $ C.unqualify x-          maxDist n = div n 3-          close a b = editDistance a b <= maxDist (length a)-          ys = map P.prettyShow $ filter (close (strip x) . strip) inscope+    AsPatternShadowsConstructorOrPatternSynonym patsyn -> fsep $ concat+      [ pwords "Name bound in @-pattern ignored because it shadows"+      , if patsyn then pwords "pattern synonym" else [ "constructor" ]+      ] +    RecordFieldWarning w -> prettyRecordFieldWarning w +prettyRecordFieldWarning :: MonadPretty m => RecordFieldWarning -> m Doc+prettyRecordFieldWarning = \case+  DuplicateFieldsWarning xrs    -> prettyDuplicateFields $ map fst xrs+  TooManyFieldsWarning q ys xrs -> prettyTooManyFields q ys $ map fst xrs++prettyDuplicateFields :: MonadPretty m => [C.Name] -> m Doc+prettyDuplicateFields xs = fsep $ concat+    [ pwords "Duplicate"+    , fields xs+    , punctuate comma (map pretty xs)+    , pwords "in record"+    ]+  where+  fields ys = P.singPlural ys [text "field"] [text "fields"]++prettyTooManyFields :: MonadPretty m => QName -> [C.Name] -> [C.Name] -> m Doc+prettyTooManyFields r missing xs = fsep $ concat+    [ pwords "The record type"+    , [prettyTCM r]+    , pwords "does not have the"+    , fields xs+    , punctuate comma (map pretty xs)+    , if null missing then [] else concat+      [ pwords "but it would have the"+      , fields missing+      , punctuate comma (map pretty missing)+      ]+    ]+  where+  fields ys = P.singPlural ys [text "field"] [text "fields"]++-- | Report a number of names that are not in scope.+prettyNotInScopeNames+  :: (MonadPretty m, Pretty a, HasRange a)+  => Bool          -- ^ Print range?+  -> (a -> m Doc)  -- ^ Correction suggestion generator.+  -> [a]           -- ^ Names that are not in scope.+  -> m Doc+prettyNotInScopeNames printRange suggestion xs = nest 2 $ vcat $ map name xs+  where+  name x = fsep+    [ pretty x+    , if printRange then "at" <+> prettyTCM (getRange x) else empty+    , suggestion x+    ]++-- | Suggest some corrections to a misspelled name.+didYouMean+  :: (MonadPretty m, Pretty a, Pretty b)+  => [C.QName]     -- ^ Names in scope.+  -> (a -> b)      -- ^ Canonization function for similarity search.+  -> a             -- ^ A name which is not in scope.+  -> Maybe (m Doc) -- ^ "did you mean" hint.+didYouMean inscope canon x+  | null ys   = Nothing+  | otherwise = Just $ sep+      [ "did you mean"+      , nest 2 (vcat $ punctuate " or" $+                 map (\ y -> text $ "'" ++ y ++ "'") ys)+        <> "?"+      ]+  where+  strip :: Pretty b => b -> String+  strip        = map toLower . filter (/= '_') . prettyShow+  -- dropModule x = fromMaybe x $ List.stripPrefix "module " x+  maxDist n    = div n 3+  close a b    = editDistance a b <= maxDist (length a)+  ys           = map prettyShow $ filter (close (strip $ canon x) . strip . C.unqualify) inscope++ prettyTCWarnings :: [TCWarning] -> TCM String prettyTCWarnings = fmap (unlines . List.intersperse "") . prettyTCWarnings' @@ -305,37 +418,39 @@   -- If there are several warnings, remove the unsolved-constraints warning   -- in case there are no interesting constraints to list.   ws  -> (`filter` ws) $ \ w -> case tcWarning w of-    UnsolvedConstraints cs -> not $ null $ filter interestingConstraint cs+    UnsolvedConstraints cs -> any interestingConstraint cs     _ -> True  --- | Turns all warnings into errors.-tcWarningsToError :: [TCWarning] -> TCM a-tcWarningsToError ws = typeError $ case ws of-  [] -> SolvedButOpenHoles-  _  -> NonFatalErrors ws+-- | Turns warnings, if any, into errors.+tcWarningsToError :: [TCWarning] -> TCM ()+tcWarningsToError mws = case (unsolvedHoles, otherWarnings) of+   ([], [])                   -> return ()+   (_unsolvedHoles@(_:_), []) -> typeError SolvedButOpenHoles+   (_, ws@(_:_))              -> typeError $ NonFatalErrors ws+   where+   -- filter out unsolved interaction points for imported module so+   -- that we get the right error message (see test case Fail/Issue1296)+   (unsolvedHoles, otherWarnings) = List.partition (isUnsolvedIM . tcWarning) mws+   isUnsolvedIM UnsolvedInteractionMetas{} = True+   isUnsolvedIM _                          = False   -- | Depending which flags are set, one may happily ignore some -- warnings. -applyFlagsToTCWarnings' :: MainInterface -> [TCWarning] -> TCM [TCWarning]-applyFlagsToTCWarnings' isMain ws = do-+applyFlagsToTCWarningsPreserving :: HasOptions m => Set WarningName -> [TCWarning] -> m [TCWarning]+applyFlagsToTCWarningsPreserving additionalKeptWarnings ws = do   -- For some reason some SafeFlagPragma seem to be created multiple times.   -- This is a way to collect all of them and remove duplicates.   let pragmas w = case tcWarning w of { SafeFlagPragma ps -> ([w], ps); _ -> ([], []) }   let sfp = case fmap List.nub (foldMap pragmas ws) of-              (TCWarning r w p b:_, sfp) ->-                 [TCWarning r (SafeFlagPragma sfp) p b]+              (TCWarning loc r w p b:_, sfp) ->+                 [TCWarning loc r (SafeFlagPragma sfp) p b]               _                        -> [] -  warnSet <- do-    opts <- pragmaOptions-    let warnSet = optWarningMode opts ^. warningSet-    pure $ if isMain /= NotMainInterface-           then Set.union warnSet unsolvedWarnings-           else warnSet+  pragmaWarnings <- (^. warningSet) . optWarningMode <$> pragmaOptions+  let warnSet = Set.union pragmaWarnings additionalKeptWarnings    -- filter out the warnings the flags told us to ignore   let cleanUp w = let wName = warningName w in@@ -349,5 +464,47 @@    return $ sfp ++ filter (cleanUp . tcWarning) ws -applyFlagsToTCWarnings :: [TCWarning] -> TCM [TCWarning]-applyFlagsToTCWarnings = applyFlagsToTCWarnings' NotMainInterface+applyFlagsToTCWarnings :: HasOptions m => [TCWarning] -> m [TCWarning]+applyFlagsToTCWarnings = applyFlagsToTCWarningsPreserving Set.empty++getAllUnsolvedWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => m [TCWarning]+getAllUnsolvedWarnings = do+  unsolvedInteractions <- getUnsolvedInteractionMetas+  unsolvedConstraints  <- getAllConstraints+  unsolvedMetas        <- getUnsolvedMetas++  let checkNonEmpty c rs = c rs <$ guard (not $ null rs)++  mapM warning_ $ catMaybes+                [ checkNonEmpty UnsolvedInteractionMetas unsolvedInteractions+                , checkNonEmpty UnsolvedMetaVariables    unsolvedMetas+                , checkNonEmpty UnsolvedConstraints      unsolvedConstraints ]++-- | Collect all warnings that have accumulated in the state.++getAllWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => WhichWarnings -> m [TCWarning]+getAllWarnings = getAllWarningsPreserving Set.empty++getAllWarningsPreserving :: (MonadFail m, ReadTCState m, MonadWarning m) => Set WarningName -> WhichWarnings -> m [TCWarning]+getAllWarningsPreserving keptWarnings ww = do+  unsolved            <- getAllUnsolvedWarnings+  collectedTCWarnings <- useTC stTCWarnings++  let showWarn w = classifyWarning w <= ww &&+                    not (null unsolved && onlyShowIfUnsolved w)++  fmap (filter (showWarn . tcWarning))+    $ applyFlagsToTCWarningsPreserving keptWarnings+    $ reverse $ unsolved ++ collectedTCWarnings++getAllWarningsOfTCErr :: TCErr -> TCM [TCWarning]+getAllWarningsOfTCErr err = case err of+  TypeError _ tcst cls -> case clValue cls of+    NonFatalErrors{} -> return []+    _ -> localTCState $ do+      putTC tcst+      ws <- getAllWarnings AllWarnings+      -- We filter out the unsolved(Metas/Constraints) to stay+      -- true to the previous error messages.+      return $ filter (not . isUnsolvedWarning . tcWarning) ws+  _ -> return []

src/full/Agda/TypeChecking/Pretty/Warning.hs-boot view

@@ -1,7 +1,7 @@ module Agda.TypeChecking.Pretty.Warning where +import Agda.Utils.Pretty import Agda.TypeChecking.Monad.Base-import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM)--instance PrettyTCM Warning+import {-# SOURCE #-} Agda.TypeChecking.Pretty (MonadPretty) +prettyWarning :: MonadPretty m => Warning -> m Doc

src/full/Agda/TypeChecking/Primitive.hs view

@@ -1,7 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE NondecreasingIndentation   #-}-{-# LANGUAGE MonoLocalBinds             #-}  {-| Primitive functions, such as addition on builtin integers. -}@@ -12,9 +8,13 @@        ) where  import Data.Char+import Data.Function (on) import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T import Data.Word  import qualified Agda.Interaction.Options.Lenses as Lens@@ -25,10 +25,8 @@ import Agda.Syntax.Internal.Generic (TermLike(..)) import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Literal-import Agda.Syntax.Fixity  import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst)-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad as Reduce import Agda.TypeChecking.Substitute@@ -40,13 +38,13 @@ import Agda.TypeChecking.Primitive.Cubical import Agda.TypeChecking.Warnings +import Agda.Utils.Char import Agda.Utils.Float import Agda.Utils.List import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Pretty import Agda.Utils.Singleton import Agda.Utils.Size-import Agda.Utils.String ( Str(Str), unStr )  import Agda.Utils.Impossible @@ -66,21 +64,31 @@   traverseTermM _ = pure   foldTerm _      = mempty -instance Show Nat where-  show = show . toInteger+instance Pretty Nat where+  pretty = pretty . toInteger  newtype Lvl = Lvl { unLvl :: Integer }   deriving (Eq, Ord) -instance Show Lvl where-  show = show . unLvl+instance Pretty Lvl where+  pretty = pretty . unLvl  class PrimType a where   primType :: a -> TCM Type +  -- This used to be a catch-all instance `PrimType a => PrimTerm a` which required UndecidableInstances.+  -- Now we declare the instances separately, but enforce the catch-all-ness with a superclass constraint on PrimTerm.+  default primType :: PrimTerm a => a -> TCM Type+  primType _ = el $ primTerm (undefined :: a)++class PrimType a => PrimTerm a where+  primTerm :: a -> TCM Term++instance (PrimType a, PrimType b) => PrimType (a -> b) instance (PrimType a, PrimType b) => PrimTerm (a -> b) where   primTerm _ = unEl <$> (primType (undefined :: a) --> primType (undefined :: b)) +instance (PrimType a, PrimType b) => PrimType (a, b) instance (PrimType a, PrimType b) => PrimTerm (a, b) where   primTerm _ = do     sigKit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit@@ -94,27 +102,51 @@              <@> pure (unEl a')              <@> pure (nolam $ unEl b') -instance PrimTerm a => PrimType a where-  primType _ = el $ primTerm (undefined :: a)--class    PrimTerm a       where primTerm :: a -> TCM Term+instance PrimType Integer instance PrimTerm Integer where primTerm _ = primInteger++instance PrimType Word64 instance PrimTerm Word64  where primTerm _ = primWord64++instance PrimType Bool instance PrimTerm Bool    where primTerm _ = primBool++instance PrimType Char instance PrimTerm Char    where primTerm _ = primChar++instance PrimType Double instance PrimTerm Double  where primTerm _ = primFloat-instance PrimTerm Str     where primTerm _ = primString++instance PrimType Text+instance PrimTerm Text    where primTerm _ = primString++instance PrimType Nat instance PrimTerm Nat     where primTerm _ = primNat++instance PrimType Lvl instance PrimTerm Lvl     where primTerm _ = primLevel++instance PrimType QName instance PrimTerm QName   where primTerm _ = primQName++instance PrimType MetaId instance PrimTerm MetaId  where primTerm _ = primAgdaMeta++instance PrimType Type instance PrimTerm Type    where primTerm _ = primAgdaTerm +instance PrimType Fixity' instance PrimTerm Fixity' where primTerm _ = primFixity +instance PrimTerm a => PrimType [a] instance PrimTerm a => PrimTerm [a] where   primTerm _ = list (primTerm (undefined :: a)) +instance PrimTerm a => PrimType (Maybe a)+instance PrimTerm a => PrimTerm (Maybe a) where+  primTerm _ = tMaybe (primTerm (undefined :: a))++instance PrimTerm a => PrimType (IO a) instance PrimTerm a => PrimTerm (IO a) where   primTerm _ = io (primTerm (undefined :: a)) @@ -126,17 +158,17 @@    toTermR = (pure .) <$> toTerm -instance ToTerm Nat     where toTerm = return $ Lit . LitNat noRange . toInteger-instance ToTerm Word64  where toTerm = return $ Lit . LitWord64 noRange+instance ToTerm Nat     where toTerm = return $ Lit . LitNat . toInteger+instance ToTerm Word64  where toTerm = return $ Lit . LitWord64 instance ToTerm Lvl     where toTerm = return $ Level . ClosedLevel . unLvl-instance ToTerm Double  where toTerm = return $ Lit . LitFloat noRange-instance ToTerm Char    where toTerm = return $ Lit . LitChar noRange-instance ToTerm Str     where toTerm = return $ Lit . LitString noRange . unStr-instance ToTerm QName   where toTerm = return $ Lit . LitQName noRange+instance ToTerm Double  where toTerm = return $ Lit . LitFloat+instance ToTerm Char    where toTerm = return $ Lit . LitChar+instance ToTerm Text    where toTerm = return $ Lit . LitString+instance ToTerm QName   where toTerm = return $ Lit . LitQName instance ToTerm MetaId  where   toTerm = do     file <- getCurrentPath-    return $ Lit . LitMeta noRange file+    return $ Lit . LitMeta file  instance ToTerm Integer where   toTerm = do@@ -156,11 +188,11 @@  instance ToTerm Term where   toTerm  = do kit <- quotingKit; runReduceF (quoteTermWithKit kit)-  toTermR = do kit <- quotingKit; return (quoteTermWithKit kit)+  toTermR = do quoteTermWithKit <$> quotingKit;  instance ToTerm Type where   toTerm  = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit)-  toTermR = do kit <- quotingKit; return (quoteTypeWithKit kit)+  toTermR = quoteTypeWithKit <$> quotingKit  instance ToTerm ArgInfo where   toTerm = do@@ -237,6 +269,13 @@     fromA  <- toTerm     return $ mkList . map fromA +instance ToTerm a => ToTerm (Maybe a) where+  toTerm = do+    nothing <- primNothing+    just    <- primJust+    fromA   <- toTerm+    return $ maybe nothing (apply1 just . fromA)+ -- From Haskell value to Agda term  type FromTermFunction a = Arg Term ->@@ -267,51 +306,51 @@         _ -> return $ NoReduction (reduced b)  instance FromTerm Nat where-  fromTerm = fromLiteral $ \l -> case l of-    LitNat _ n -> Just $ fromInteger n-    _          -> Nothing+  fromTerm = fromLiteral $ \case+    LitNat n -> Just $ fromInteger n+    _ -> Nothing  instance FromTerm Word64 where   fromTerm = fromLiteral $ \ case-    LitWord64 _ n -> Just n-    _             -> Nothing+    LitWord64 n -> Just n+    _ -> Nothing  instance FromTerm Lvl where-  fromTerm = fromReducedTerm $ \l -> case l of+  fromTerm = fromReducedTerm $ \case     Level (ClosedLevel n) -> Just $ Lvl n-    _                     -> Nothing+    _ -> Nothing  instance FromTerm Double where-  fromTerm = fromLiteral $ \l -> case l of-    LitFloat _ x -> Just x-    _            -> Nothing+  fromTerm = fromLiteral $ \case+    LitFloat x -> Just x+    _ -> Nothing  instance FromTerm Char where-  fromTerm = fromLiteral $ \l -> case l of-    LitChar _ c -> Just c-    _           -> Nothing+  fromTerm = fromLiteral $ \case+    LitChar c -> Just c+    _ -> Nothing -instance FromTerm Str where-  fromTerm = fromLiteral $ \l -> case l of-    LitString _ s -> Just $ Str s-    _             -> Nothing+instance FromTerm Text where+  fromTerm = fromLiteral $ \case+    LitString s -> Just s+    _ -> Nothing  instance FromTerm QName where-  fromTerm = fromLiteral $ \l -> case l of-    LitQName _ x -> Just x-    _             -> Nothing+  fromTerm = fromLiteral $ \case+    LitQName x -> Just x+    _ -> Nothing  instance FromTerm MetaId where-  fromTerm = fromLiteral $ \l -> case l of-    LitMeta _ _ x -> Just x-    _             -> Nothing+  fromTerm = fromLiteral $ \case+    LitMeta _ x -> Just x+    _ -> Nothing  instance FromTerm Bool where     fromTerm = do         true  <- primTrue         false <- primFalse-        fromReducedTerm $ \t -> case t of-            _   | t =?= true  -> Just True+        fromReducedTerm $ \case+            t   | t =?= true  -> Just True                 | t =?= false -> Just False                 | otherwise   -> Nothing         where@@ -323,17 +362,14 @@  instance (ToTerm a, FromTerm a) => FromTerm [a] where   fromTerm = do-    nil'  <- primNil-    cons' <- primCons-    nil   <- isCon nil'-    cons  <- isCon cons'+    nil   <- isCon <$> primNil+    cons  <- isCon <$> primCons     toA   <- fromTerm-    fromA <- toTerm-    return $ mkList nil cons toA fromA+    mkList nil cons toA <$> toTerm     where-      isCon (Lam _ b)  = isCon $ absBody b-      isCon (Con c _ _)= return c-      isCon v          = __IMPOSSIBLE__+      isCon (Lam _ b)   = isCon $ absBody b+      isCon (Con c _ _) = c+      isCon v           = __IMPOSSIBLE__        mkList nil cons toA fromA t = do         b <- reduceB' t@@ -352,6 +388,31 @@               redReturn (y : ys)           _ -> return $ NoReduction (reduced b) +instance FromTerm a => FromTerm (Maybe a) where+  fromTerm = do+    nothing <- isCon <$> primNothing+    just    <- isCon <$> primJust+    toA     <- fromTerm+    return $ \ t -> do+      let arg = (<$ t)+      b <- reduceB' t+      let t = ignoreBlocking b+      case unArg t of+        Con c ci []+          | c == nothing -> return $ YesReduction NoSimplification Nothing+        Con c ci es+          | c == just, Just [x] <- allApplyElims es ->+            redBind (toA x)+              (\ x' -> notReduced $ arg $ Con c ci [Apply (ignoreReduced x')])+              (redReturn . Just)+        _ -> return $ NoReduction (reduced b)++    where+      isCon (Lam _ b)   = isCon $ absBody b+      isCon (Con c _ _) = c+      isCon v           = __IMPOSSIBLE__++ fromReducedTerm :: (Term -> Maybe a) -> TCM (FromTermFunction a) fromReducedTerm f = return $ \t -> do     b <- reduceB' t@@ -360,7 +421,7 @@         Nothing -> return $ NoReduction (reduced b)  fromLiteral :: (Literal -> Maybe a) -> TCM (FromTermFunction a)-fromLiteral f = fromReducedTerm $ \t -> case t of+fromLiteral f = fromReducedTerm $ \case     Lit lit -> f lit     _       -> Nothing @@ -387,8 +448,7 @@   return $ PrimImpl ty $ primFun __IMPOSSIBLE__ 3 $ \ ts -> do     let t  = headWithDefault __IMPOSSIBLE__ ts     let eq = unArg $ fromMaybe __IMPOSSIBLE__ $ lastMaybe ts-    eq' <- normalise' eq-    case eq' of+    reduce' eq >>= \case       Con{} -> redReturn $ refl t       _     -> return $ NoReduction $ map notReduced ts @@ -408,11 +468,18 @@  primStringToListInjective :: TCM PrimitiveImpl primStringToListInjective = do-  string <- primType (undefined :: Str)+  string <- primType (undefined :: Text)   chars  <- primType (undefined :: String)   toList <- primFunName <$> getPrimitive "primStringToList"   mkPrimInjective string chars toList +primStringFromListInjective :: TCM PrimitiveImpl+primStringFromListInjective = do+  chars  <- primType (undefined :: String)+  string <- primType (undefined :: Text)+  fromList <- primFunName <$> getPrimitive "primStringFromList"+  mkPrimInjective chars string fromList+ primWord64ToNatInjective :: TCM PrimitiveImpl primWord64ToNatInjective =  do   word  <- primType (undefined :: Word64)@@ -480,7 +547,12 @@     -- and the conversion checker for eliminations does not     -- like this.     -- We can only do untyped equality, e.g., by normalisation.-    (u', v') <- normalise' (u, v)+    -- Jesper, 2020-04-04: We reduce rather than normalise for+    -- efficiency reasons. In general this is weaker but it is+    -- equivalent at base types. A stronger version of+    -- primEraseEquality (using type-directed conversion) may be+    -- implemented using --rewriting.+    (u', v') <- reduce' (u, v)     if u' == v' then redReturn $ refl u else       return $ NoReduction $ map notReduced ts @@ -535,8 +607,8 @@                     Datatype{} -> True                     Record{}   -> True                     _          -> False-                MetaV{}    -> return False                 Var{}      -> return False+                MetaV{}    -> __IMPOSSIBLE__                 Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s         ifM (isWHNF u)             (redReturn $ ret (unArg f) (ignoreBlocking u))@@ -547,9 +619,8 @@ primForce = do   let varEl s a = El (varSort s) <$> a       varT s a  = varEl s (varM a)-      varS s    = pure $ sort $ varSort s   genPrimForce (nPi "x" (varT 3 1) $-                (nPi "y" (varT 4 2) $ varEl 4 $ varM 2 <@> varM 0) -->+                nPi "y" (varT 4 2) (varEl 4 $ varM 2 <@> varM 0) -->                 varEl 3 (varM 1 <@> varM 0)) $     \ f u -> apply f [u] @@ -557,7 +628,6 @@ primForceLemma = do   let varEl s a = El (varSort s) <$> a       varT s a  = varEl s (varM a)-      varS s    = pure $ sort $ varSort s   refl  <- primRefl   force <- primFunName <$> getPrimitive "primForce"   genPrimForce (nPi "x" (varT 3 1) $@@ -587,12 +657,24 @@     b' <- levelView' $ unArg b     redReturn $ Level $ levelLub a' b' -mkPrimSetOmega :: TCM PrimitiveImpl-mkPrimSetOmega = do-  let t = sort $ UnivSort Inf-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort Inf+mkPrimSetOmega :: IsFibrant -> TCM PrimitiveImpl+mkPrimSetOmega f = do+  let t = sort $ Inf f 1+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort $ Inf f 0 -mkPrimFun1TCM :: (FromTerm a, ToTerm b, TermLike b) =>+primLockUniv' :: TCM PrimitiveImpl+primLockUniv' = do+  let t = sort $ Type $ levelSuc $ Max 0 []+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort LockUniv++-- mkPrimStrictSet :: TCM PrimitiveImpl+-- mkPrimStrictSet = do+--   t <- nPi "ℓ" (el primLevel) (pure $ sort $ SSet $ Max 0 [Plus 1 $ var 0])+--   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ~[a] -> do+--     l <- levelView' $ unArg a+--     redReturn $ Sort $ SSet l++mkPrimFun1TCM :: (FromTerm a, ToTerm b) =>                  TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl mkPrimFun1TCM mt f = do     toA   <- fromTerm@@ -602,10 +684,10 @@       case ts of         [v] ->           redBind (toA v) singleton $ \ x -> do-            b <- f x-            case firstMeta b of-              Just m  -> return $ NoReduction [reduced (Blocked m v)]-              Nothing -> redReturn =<< fromB b+            b <- fromB =<< f x+            case allMetas Set.singleton b of+              ms | Set.null ms -> redReturn b+                 | otherwise   -> return $ NoReduction [reduced (Blocked (unblockOnAllMetas ms) v)]         _ -> __IMPOSSIBLE__  -- Tying the knot@@ -643,6 +725,31 @@           redReturn $ fromC $ f x y         _ -> __IMPOSSIBLE__ +mkPrimFun3 :: ( PrimType a, FromTerm a, ToTerm a+              , PrimType b, FromTerm b, ToTerm b+              , PrimType c, FromTerm c+              , PrimType d, ToTerm d ) =>+              (a -> b -> c -> d) -> TCM PrimitiveImpl+mkPrimFun3 f = do+    (toA, fromA) <- (,) <$> fromTerm <*> toTerm+    (toB, fromB) <- (,) <$> fromTerm <*> toTerm+    toC          <- fromTerm+    fromD        <- toTerm+    t <- primType f+    return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ts ->+      let argFrom fromX a x =+            reduced $ notBlocked $ Arg (argInfo a) (fromX x)+      in case ts of+        [a,b,c] ->+          redBind (toA a)+              (\a' -> [a', notReduced b, notReduced c]) $ \x ->+          redBind (toB b)+              (\b' -> [argFrom fromA a x, b', notReduced c]) $ \y ->+          redBind (toC c)+              (\c' -> [ argFrom fromA a x, argFrom fromB b y, c']) $ \z ->+          redReturn $ fromD $ f x y z+        _ -> __IMPOSSIBLE__+ mkPrimFun4 :: ( PrimType a, FromTerm a, ToTerm a               , PrimType b, FromTerm b, ToTerm b               , PrimType c, FromTerm c, ToTerm c@@ -689,7 +796,7 @@ type Pred a = a -> Bool  primitiveFunctions :: Map String (TCM PrimitiveImpl)-primitiveFunctions = fmap localTCStateSavingWarnings $ Map.fromList+primitiveFunctions = localTCStateSavingWarnings <$> Map.fromList   -- Issue #4375          ^^^^^^^^^^^^^^^^^^^^^^^^^^   --   Without this the next fresh checkpoint id gets changed building the primitive functions. This   --   is bad for caching since it happens when scope checking import declarations (rebinding@@ -712,7 +819,7 @@   -- , "primIntegerLess"     |-> mkPrimFun2 ((<)        :: Rel Integer)   -- , "primIntegerAbs"      |-> mkPrimFun1 (Nat . abs  :: Integer -> Nat)   -- , "primNatToInteger"    |-> mkPrimFun1 (toInteger  :: Nat -> Integer)-  [ "primShowInteger"     |-> mkPrimFun1 (Str . show :: Integer -> Str)+  [ "primShowInteger"     |-> mkPrimFun1 (T.pack . prettyShow :: Integer -> Text)    -- Natural number functions   , "primNatPlus"         |-> mkPrimFun2 ((+)                     :: Op Nat)@@ -726,7 +833,7 @@       in mkPrimFun4 aux   , "primNatEquality"     |-> mkPrimFun2 ((==) :: Rel Nat)   , "primNatLess"         |-> mkPrimFun2 ((<)  :: Rel Nat)-  , "primShowNat"         |-> mkPrimFun1 (Str . show :: Nat -> Str)+  , "primShowNat"         |-> mkPrimFun1 (T.pack . prettyShow :: Nat -> Text)    -- Machine words   , "primWord64ToNat"     |-> mkPrimFun1 (fromIntegral :: Word64 -> Nat)@@ -739,38 +846,59 @@   , "primLevelMax"        |-> mkPrimLevelMax    -- Sorts-  , "primSetOmega"        |-> mkPrimSetOmega+  , "primSetOmega"        |-> mkPrimSetOmega IsFibrant+  , "primStrictSetOmega"  |-> mkPrimSetOmega IsStrict    -- Floating point functions-  , "primNatToFloat"      |-> mkPrimFun1 (fromIntegral    :: Nat -> Double)-  , "primFloatPlus"       |-> mkPrimFun2 ((+)             :: Op Double)-  , "primFloatMinus"      |-> mkPrimFun2 ((-)             :: Op Double)-  , "primFloatTimes"      |-> mkPrimFun2 ((*)             :: Op Double)-  , "primFloatNegate"     |-> mkPrimFun1 (negate          :: Fun Double)-  , "primFloatDiv"        |-> mkPrimFun2 ((/)             :: Op Double)-  -- ASR (2016-09-29). We use bitwise equality for comparing Double-  -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove-  -- a contradiction (see Issue #2169).-  , "primFloatEquality"   |-> mkPrimFun2 (floatEq         :: Rel Double)-  , "primFloatLess"       |-> mkPrimFun2 (floatLt         :: Rel Double)-  , "primFloatNumericalEquality" |-> mkPrimFun2 ((==)     :: Rel Double)-  , "primFloatNumericalLess"     |-> mkPrimFun2 ((<)      :: Rel Double)-  , "primFloatSqrt"       |-> mkPrimFun1 (sqrt            :: Double -> Double)-  , "primRound"           |-> mkPrimFun1 (round   . normaliseNaN :: Double -> Integer)-  , "primFloor"           |-> mkPrimFun1 (floor   . normaliseNaN :: Double -> Integer)-  , "primCeiling"         |-> mkPrimFun1 (ceiling . normaliseNaN :: Double -> Integer)-  , "primExp"             |-> mkPrimFun1 (exp             :: Fun Double)-  , "primLog"             |-> mkPrimFun1 (log             :: Fun Double)-  , "primSin"             |-> mkPrimFun1 (sin             :: Fun Double)-  , "primCos"             |-> mkPrimFun1 (cos             :: Fun Double)-  , "primTan"             |-> mkPrimFun1 (tan             :: Fun Double)-  , "primASin"            |-> mkPrimFun1 (asin            :: Fun Double)-  , "primACos"            |-> mkPrimFun1 (acos            :: Fun Double)-  , "primATan"            |-> mkPrimFun1 (atan            :: Fun Double)-  , "primATan2"           |-> mkPrimFun2 (atan2           :: Op Double)-  , "primShowFloat"       |-> mkPrimFun1 (Str . show      :: Double -> Str)-  , "primFloatToWord64"   |-> mkPrimFun1 doubleToWord64+  --+  -- Wen, 2020-08-26: Primitives which convert from Float into other, more+  -- well-behaved numeric types should check for unrepresentable values, e.g.,+  -- NaN and the infinities, and return `nothing` if those are encountered, to+  -- ensure that the returned numbers are sensible. That means `primFloatRound`,+  -- `primFloatFloor`, `primFloatCeiling`, and `primFloatDecode`. The conversion+  -- `primFloatRatio` represents NaN as (0,0), and the infinities as (±1,0).+  --+  , "primFloatEquality"          |-> mkPrimFun2 doubleEq+  , "primFloatInequality"        |-> mkPrimFun2 doubleLe+  , "primFloatLess"              |-> mkPrimFun2 doubleLt+  , "primFloatIsInfinite"        |-> mkPrimFun1 (isInfinite :: Double -> Bool)+  , "primFloatIsNaN"             |-> mkPrimFun1 (isNaN :: Double -> Bool)+  , "primFloatIsNegativeZero"    |-> mkPrimFun1 (isNegativeZero :: Double -> Bool)+  , "primFloatIsSafeInteger"     |-> mkPrimFun1 isSafeInteger+  , "primFloatToWord64"          |-> mkPrimFun1 doubleToWord64   , "primFloatToWord64Injective" |-> primFloatToWord64Injective+  , "primNatToFloat"             |-> mkPrimFun1 (intToDouble :: Nat -> Double)+  , "primIntToFloat"             |-> mkPrimFun1 (intToDouble :: Integer -> Double)+  , "primFloatRound"             |-> mkPrimFun1 doubleRound+  , "primFloatFloor"             |-> mkPrimFun1 doubleFloor+  , "primFloatCeiling"           |-> mkPrimFun1 doubleCeiling+  , "primFloatToRatio"           |-> mkPrimFun1 doubleToRatio+  , "primRatioToFloat"           |-> mkPrimFun2 ratioToDouble+  , "primFloatDecode"            |-> mkPrimFun1 doubleDecode+  , "primFloatEncode"            |-> mkPrimFun2 doubleEncode+  , "primShowFloat"              |-> mkPrimFun1 (T.pack . show :: Double -> Text)+  , "primFloatPlus"              |-> mkPrimFun2 doublePlus+  , "primFloatMinus"             |-> mkPrimFun2 doubleMinus+  , "primFloatTimes"             |-> mkPrimFun2 doubleTimes+  , "primFloatNegate"            |-> mkPrimFun1 doubleNegate+  , "primFloatDiv"               |-> mkPrimFun2 doubleDiv+  , "primFloatPow"               |-> mkPrimFun2 doublePow+  , "primFloatSqrt"              |-> mkPrimFun1 doubleSqrt+  , "primFloatExp"               |-> mkPrimFun1 doubleExp+  , "primFloatLog"               |-> mkPrimFun1 doubleLog+  , "primFloatSin"               |-> mkPrimFun1 doubleSin+  , "primFloatCos"               |-> mkPrimFun1 doubleCos+  , "primFloatTan"               |-> mkPrimFun1 doubleTan+  , "primFloatASin"              |-> mkPrimFun1 doubleASin+  , "primFloatACos"              |-> mkPrimFun1 doubleACos+  , "primFloatATan"              |-> mkPrimFun1 doubleATan+  , "primFloatATan2"             |-> mkPrimFun2 doubleATan2+  , "primFloatSinh"              |-> mkPrimFun1 doubleSinh+  , "primFloatCosh"              |-> mkPrimFun1 doubleCosh+  , "primFloatTanh"              |-> mkPrimFun1 doubleTanh+  , "primFloatASinh"             |-> mkPrimFun1 doubleASinh+  , "primFloatACosh"             |-> mkPrimFun1 doubleCosh+  , "primFloatATanh"             |-> mkPrimFun1 doubleTanh    -- Character functions   , "primCharEquality"       |-> mkPrimFun2 ((==) :: Rel Char)@@ -786,16 +914,18 @@   , "primToLower"            |-> mkPrimFun1 toLower   , "primCharToNat"          |-> mkPrimFun1 (fromIntegral . fromEnum :: Char -> Nat)   , "primCharToNatInjective" |-> primCharToNatInjective-  , "primNatToChar"          |-> mkPrimFun1 (toEnum . fromIntegral . (`mod` 0x110000)  :: Nat -> Char)-  , "primShowChar"           |-> mkPrimFun1 (Str . prettyShow . LitChar noRange)+  , "primNatToChar"          |-> mkPrimFun1 (integerToChar . unNat)+  , "primShowChar"           |-> mkPrimFun1 (T.pack . prettyShow . LitChar)    -- String functions-  , "primStringToList"          |-> mkPrimFun1 unStr-  , "primStringToListInjective" |-> primStringToListInjective-  , "primStringFromList"        |-> mkPrimFun1 Str-  , "primStringAppend"          |-> mkPrimFun2 (\s1 s2 -> Str $ unStr s1 ++ unStr s2)-  , "primStringEquality"        |-> mkPrimFun2 ((==) :: Rel Str)-  , "primShowString"            |-> mkPrimFun1 (Str . prettyShow . LitString noRange . unStr)+  , "primStringToList"            |-> mkPrimFun1 T.unpack+  , "primStringToListInjective"   |-> primStringToListInjective+  , "primStringFromList"          |-> mkPrimFun1 T.pack+  , "primStringFromListInjective" |-> primStringFromListInjective+  , "primStringAppend"            |-> mkPrimFun2 (T.append :: Text -> Text -> Text)+  , "primStringEquality"          |-> mkPrimFun2 ((==) :: Rel Text)+  , "primShowString"              |-> mkPrimFun1 (T.pack . prettyShow . LitString)+  , "primStringUncons"            |-> mkPrimFun1 T.uncons    -- Other stuff   , "primEraseEquality"   |-> primEraseEquality@@ -804,14 +934,14 @@   , "primForceLemma"      |-> primForceLemma   , "primQNameEquality"   |-> mkPrimFun2 ((==) :: Rel QName)   , "primQNameLess"       |-> mkPrimFun2 ((<) :: Rel QName)-  , "primShowQName"       |-> mkPrimFun1 (Str . prettyShow :: QName -> Str)+  , "primShowQName"       |-> mkPrimFun1 (T.pack . prettyShow :: QName -> Text)   , "primQNameFixity"     |-> mkPrimFun1 (nameFixity . qnameName)-  , "primQNameToWord64s"  |-> mkPrimFun1 ((\ (NameId x y) -> (x, y)) . nameId . qnameName+  , "primQNameToWord64s"  |-> mkPrimFun1 ((\ (NameId x (ModuleNameHash y)) -> (x, y)) . nameId . qnameName                                           :: QName -> (Word64, Word64))   , "primQNameToWord64sInjective" |-> primQNameToWord64sInjective   , "primMetaEquality"    |-> mkPrimFun2 ((==) :: Rel MetaId)   , "primMetaLess"        |-> mkPrimFun2 ((<) :: Rel MetaId)-  , "primShowMeta"        |-> mkPrimFun1 (Str . prettyShow :: MetaId -> Str)+  , "primShowMeta"        |-> mkPrimFun1 (T.pack . prettyShow :: MetaId -> Text)   , "primMetaToNat"       |-> mkPrimFun1 (fromIntegral . metaId :: MetaId -> Nat)   , "primMetaToNatInjective" |-> primMetaToNatInjective   , "primIMin"            |-> primIMin'@@ -835,6 +965,7 @@   , builtinSubOut         |-> primSubOut'   , builtin_glueU         |-> prim_glueU'   , builtin_unglueU       |-> prim_unglueU'+  , builtinLockUniv       |-> primLockUniv'   ]   where     (|->) = (,)

src/full/Agda/TypeChecking/Primitive/Base.hs view

@@ -1,6 +1,10 @@+{-# LANGUAGE ApplicativeDo #-}+ module Agda.TypeChecking.Primitive.Base where +-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail)+ import qualified Data.Map as Map  import Agda.Syntax.Common@@ -12,6 +16,7 @@ import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Names import {-# SOURCE #-} Agda.TypeChecking.Primitive+import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce ( reduce ) import Agda.TypeChecking.Monad.Signature import Agda.TypeChecking.Substitute@@ -27,16 +32,16 @@ infixr 4 .--> infixr 4 ..--> -(-->), (.-->), (..-->) :: Monad tcm => tcm Type -> tcm Type -> tcm Type+(-->), (.-->), (..-->) :: Applicative m => m Type -> m Type -> m Type a --> b = garr id a b a .--> b = garr (const $ Irrelevant) a b a ..--> b = garr (const $ NonStrict) a b -garr :: Monad m => (Relevance -> Relevance) -> m Type -> m Type -> m Type+garr :: Applicative m => (Relevance -> Relevance) -> m Type -> m Type -> m Type garr f a b = do   a' <- a   b' <- b-  return $ El (funSort (getSort a') (getSort b')) $+  pure $ El (funSort (getSort a') (getSort b')) $     Pi (mapRelevance f $ defaultDom a') (NoAbs "_" b')  gpi :: (MonadAddContext m, MonadDebug m)@@ -47,7 +52,7 @@       dom = defaultNamedArgDom info name a   b <- addContext (name, dom) b   let y = stringToArgName name-  return $ El (piSort dom (Abs y (getSort b)))+  return $ El (mkPiSort dom (Abs y b))               (Pi dom (Abs y b))  hPi, nPi :: (MonadAddContext m, MonadDebug m)@@ -62,7 +67,7 @@  pPi' :: (MonadAddContext m, HasBuiltins m, MonadDebug m)      => String -> NamesT m Term -> (NamesT m Term -> NamesT m Type) -> NamesT m Type-pPi' n phi b = toFinitePi <$> nPi' n (elInf $ cl isOne <@> phi) b+pPi' n phi b = toFinitePi <$> nPi' n (elSSet $ cl isOne <@> phi) b  where    toFinitePi :: Type -> Type    toFinitePi (El s (Pi d b)) = El s $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b@@ -70,71 +75,80 @@     isOne = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIsOne -el' :: Monad m => m Term -> m Term -> m Type+el' :: Applicative m => m Term -> m Term -> m Type el' l a = El <$> (tmSort <$> l) <*> a +el's :: Applicative m => m Term -> m Term -> m Type+el's l a = El <$> (SSet . atomicLevel <$> l) <*> a+ elInf :: Functor m => m Term -> m Type-elInf t = (El Inf <$> t)+elInf t = (El (Inf IsFibrant 0) <$> t) +elSSet :: Functor m => m Term -> m Type+elSSet t = (El (SSet $ ClosedLevel 0) <$> t)+ nolam :: Term -> Term nolam = Lam defaultArgInfo . NoAbs "_" -varM :: Monad tcm => Int -> tcm Term-varM = return . var+varM :: Applicative m => Int -> m Term+varM = pure . var  infixl 9 <@>, <#> -gApply :: Monad tcm => Hiding -> tcm Term -> tcm Term -> tcm Term+gApply :: Applicative m => Hiding -> m Term -> m Term -> m Term gApply h a b = gApply' (setHiding h defaultArgInfo) a b -gApply' :: Monad tcm => ArgInfo -> tcm Term -> tcm Term -> tcm Term+gApply' :: Applicative m => ArgInfo -> m Term -> m Term -> m Term gApply' info a b = do     x <- a     y <- b-    return $ x `apply` [Arg info y]+    pure $ x `apply` [Arg info y] -(<@>),(<#>),(<..>) :: Monad tcm => tcm Term -> tcm Term -> tcm Term+(<@>),(<#>),(<..>) :: Applicative m => m Term -> m Term -> m Term (<@>) = gApply NotHidden (<#>) = gApply Hidden (<..>) = gApply' (setRelevance Irrelevant defaultArgInfo) -(<@@>) :: Monad tcm => tcm Term -> (tcm Term,tcm Term,tcm Term) -> tcm Term+(<@@>) :: Applicative m => m Term -> (m Term,m Term,m Term) -> m Term t <@@> (x,y,r) = do   t <- t   x <- x   y <- y   r <- r-  return $ t `applyE` [IApply x y r]+  pure $ t `applyE` [IApply x y r]  list :: TCM Term -> TCM Term list t = primList <@> t +tMaybe :: TCM Term -> TCM Term+tMaybe t = primMaybe <@> t+ io :: TCM Term -> TCM Term io t = primIO <@> t  path :: TCM Term -> TCM Term path t = primPath <@> t -el :: Functor tcm => tcm Term -> tcm Type+el :: Functor m => m Term -> m Type el t = El (mkType 0) <$> t -tset :: Monad tcm => tcm Type-tset = return $ sort (mkType 0)+tset :: Applicative m => m Type+tset = pure $ sort (mkType 0)  sSizeUniv :: Sort-sSizeUniv = mkType 0+-- sSizeUniv = mkType 0 -- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428--- sSizeUniv = SizeUniv+sSizeUniv = SizeUniv -tSizeUniv :: Monad tcm => tcm Type-tSizeUniv = tset+tSizeUniv :: Applicative m => m Type+-- tSizeUniv = tset -- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428 -- tSizeUniv = return $ El sSizeUniv $ Sort sSizeUniv -- Andreas, 2015-03-16 Since equality checking for types -- includes equality checking for sorts, we cannot put -- SizeUniv in Setω.  (SizeUniv : Setω) == (_0 : suc _0) -- will first instantiate _0 := Setω, which is wrong.--- tSizeUniv = return $ El Inf $ Sort SizeUniv+tSizeUniv = pure $ sort sSizeUniv  -- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@. argN :: e -> Arg e@@ -156,17 +170,18 @@  lookupPrimitiveFunction :: String -> TCM PrimitiveImpl lookupPrimitiveFunction x =-  fromMaybe (typeError $ NoSuchPrimitiveFunction x)+  fromMaybe (do+                reportSDoc "tc.prim" 20 $ "Lookup of primitive function" <+> text x <+> "failed"+                typeError $ NoSuchPrimitiveFunction x)             (Map.lookup x primitiveFunctions)  lookupPrimitiveFunctionQ :: QName -> TCM (String, PrimitiveImpl) lookupPrimitiveFunctionQ q = do-  let s = case qnameName q of-            Name _ x _ _ _ -> prettyShow x+  let s = prettyShow (nameCanonical $ qnameName q)   PrimImpl t pf <- lookupPrimitiveFunction s   return (s, PrimImpl t $ pf { primFunName = q }) -getBuiltinName :: String -> TCM (Maybe QName)+getBuiltinName :: (HasBuiltins m, MonadReduce m) => String -> m (Maybe QName) getBuiltinName b = do   caseMaybeM (getBuiltin' b) (return Nothing) (Just <.> getName)   where@@ -178,7 +193,7 @@       Lam _ b   -> getName $ unAbs b       _ -> __IMPOSSIBLE__ -isBuiltin :: QName -> String -> TCM Bool+isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> String -> m Bool isBuiltin q b = (Just q ==) <$> getBuiltinName b  ------------------------------------------------------------------------

src/full/Agda/TypeChecking/Primitive/Cubical.hs view

@@ -5,6 +5,7 @@ import Prelude hiding (null, (!!))  import Control.Monad+import Control.Monad.Except import Control.Monad.Trans ( lift )  import Data.Either ( partitionEithers )@@ -22,14 +23,12 @@ import Agda.TypeChecking.Names import Agda.TypeChecking.Primitive.Base import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin  import Agda.TypeChecking.Free import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce import Agda.TypeChecking.Telescope -import Agda.Utils.Except import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Maybe@@ -37,16 +36,19 @@ import Agda.Utils.Null import Agda.Utils.Tuple -requireCubical :: TCM ()-requireCubical = do+requireCubical :: String -> TCM ()+requireCubical s = do   cubical <- optCubical <$> pragmaOptions   unless cubical $-    typeError $ GenericError "Missing option --cubical"+    typeError $ GenericError $ "Missing option --cubical" ++ s +primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type+primIntervalType = El (SSet $ ClosedLevel 0) <$> primInterval+ primINeg' :: TCM PrimitiveImpl primINeg' = do-  requireCubical-  t <- elInf primInterval --> elInf primInterval+  requireCubical ""+  t <- primIntervalType --> primIntervalType   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ts -> do     case ts of      [x] -> do@@ -71,10 +73,10 @@  primDepIMin' :: TCM PrimitiveImpl primDepIMin' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       nPi' "φ" (elInf $ cl primInterval) $ \ φ ->-       (pPi' "o" φ $ \ o -> elInf $ cl primInterval) --> elInf (cl primInterval)+       nPi' "φ" primIntervalType $ \ φ ->+       pPi' "o" φ (\ o -> primIntervalType) --> primIntervalType   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do     case ts of       [x,y] -> do@@ -95,8 +97,8 @@  primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl primIBin unit absorber = do-  requireCubical-  t <- elInf primInterval --> elInf primInterval --> elInf primInterval+  requireCubical ""+  t <- primIntervalType --> primIntervalType --> primIntervalType   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do     case ts of      [x,y] -> do@@ -121,12 +123,12 @@  primIMin' :: TCM PrimitiveImpl primIMin' = do-  requireCubical+  requireCubical ""   primIBin IOne IZero  primIMax' :: TCM PrimitiveImpl primIMax' = do-  requireCubical+  requireCubical ""   primIBin IZero IOne  imax :: HasBuiltins m => m Term -> m Term -> m Term@@ -144,18 +146,18 @@ -- ∀ {a}{c}{A : Set a}{x : A}(C : ∀ y → Id x y → Set c) → C x (conid i1 (\ i → x)) → ∀ {y} (p : Id x y) → C y p primIdJ :: TCM PrimitiveImpl primIdJ = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $        hPi' "a" (el $ cl primLevel) $ \ a ->        hPi' "c" (el $ cl primLevel) $ \ c ->        hPi' "A" (sort . tmSort <$> a) $ \ bA ->        hPi' "x" (el' a bA) $ \ x ->        nPi' "C" (nPi' "y" (el' a bA) $ \ y ->-                 (el' a $ cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->-       (el' c $ bC <@> x <@>+                 el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->+       el' c (bC <@> x <@>             (cl primConId <#> a <#> bA <#> x <#> x <@> cl primIOne                        <@> lam "i" (\ _ -> x))) -->-       (hPi' "y" (el' a bA) $ \ y ->+       hPi' "y" (el' a bA) (\ y ->         nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->         el' c $ bC <@> y <@> p)   conidn <- getBuiltinName builtinConId@@ -163,8 +165,8 @@   -- TODO make a kit   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do     unview <- intervalUnview'-    let imax x y = do x' <- x; y' <- y; pure $ unview (IMax (argN x') (argN y'))-        imin x y = do x' <- x; y' <- y; pure $ unview (IMin (argN x') (argN y'))+    let imax x y = do x' <- x; unview . IMax (argN x') . argN <$> y;+        imin x y = do x' <- x; unview . IMin (argN x') . argN <$> y;         ineg x = unview . INeg . argN <$> x     mcomp <- getTerm' "primComp"     case ts of@@ -178,39 +180,39 @@              let w i = do                    [x,y,p,i] <- sequence [x,y,p,i]                    pure $ p `applyE` [IApply x y i]-             pure comp <#> (lam "i" $ \ _ -> lc)-                       <@> (lam "i" $ \ i ->+             pure comp <#> lam "i" (\ _ -> lc)+                       <@> lam "i" (\ i ->                               c <@> (w i)                                 <@> (pure conid <#> la <#> a <#> x <#> (w i)                                                 <@> (phi `imax` ineg i)-                                                <@> (lam "j" $ \ j -> w $ imin i j)))+                                                <@> lam "j" (\ j -> w $ imin i j)))                        <#> phi-                       <@> (lam "i" $ \ _ -> nolam <$> d) -- TODO block+                       <@> lam "i" (\ _ -> nolam <$> d) -- TODO block                        <@> d          _ -> return $ NoReduction $ map notReduced [la,lc,a,x,c,d,y] ++ [reduced seq]      _ -> __IMPOSSIBLE__  primIdElim' :: TCM PrimitiveImpl primIdElim' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $        hPi' "a" (el $ cl primLevel) $ \ a ->        hPi' "c" (el $ cl primLevel) $ \ c ->        hPi' "A" (sort . tmSort <$> a) $ \ bA ->        hPi' "x" (el' a bA) $ \ x ->        nPi' "C" (nPi' "y" (el' a bA) $ \ y ->-                 (el' a $ cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->-       (nPi' "φ" (elInf $ cl primInterval) $ \ phi ->-        nPi' "y" (elInf $ cl primSub <#> a <@> bA <@> phi <@> (lam "o" $ const x)) $ \ y ->+                 el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->+       nPi' "φ" primIntervalType (\ phi ->+        nPi' "y" (el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (const x)) $ \ y ->         let pathxy = (cl primPath <#> a <@> bA <@> x <@> oucy)-            oucy = (cl primSubOut <#> a <#> bA <#> phi <#> (lam "o" $ const x) <@> y)+            oucy = (cl primSubOut <#> a <#> bA <#> phi <#> lam "o" (const x) <@> y)             reflx = (lam "o" $ \ _ -> lam "i" $ \ _ -> x) -- TODO Andrea, should block on o         in-        nPi' "w" (elInf $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w ->+        nPi' "w" (el's a $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w ->         let oucw = (cl primSubOut <#> a <#> pathxy <#> phi <#> reflx <@> w) in         el' c $ bC <@> oucy <@> (cl primConId <#> a <#> bA <#> x <#> oucy <@> phi <@> oucw))        -->-       (hPi' "y" (el' a bA) $ \ y ->+       hPi' "y" (el' a bA) (\ y ->         nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->         el' c $ bC <@> y <@> p)   conid <- primConId@@ -222,8 +224,8 @@         sp <- reduceB' p         case unArg $ ignoreBlocking sp of           Def q [Apply _a, Apply _bA, Apply _x, Apply _y, Apply phi , Apply w] -> do-            y' <- return $ sin `apply` [a,bA                            ,phi,argN $ unArg y]-            w' <- return $ sin `apply` [a,argN $ path `apply` [a,bA,x,y],phi,argN $ unArg w]+            let y' = sin `apply` [a,bA                            ,phi,argN $ unArg y]+            let w' = sin `apply` [a,argN $ path `apply` [a,bA,x,y],phi,argN $ unArg w]             redReturn $ unArg f `apply` [phi, defaultArg y', defaultArg w']           _ -> return $ NoReduction $ map notReduced [a,c,bA,x,bC,f,y] ++ [reduced sp]       _ -> __IMPOSSIBLE__@@ -231,15 +233,15 @@  primPOr :: TCM PrimitiveImpl primPOr = do-  requireCubical+  requireCubical ""   t    <- runNamesT [] $           hPi' "a" (el $ cl primLevel)    $ \ a  ->-          nPi' "i" (elInf $ cl primInterval) $ \ i  ->-          nPi' "j" (elInf $ cl primInterval) $ \ j  ->+          nPi' "i" primIntervalType $ \ i  ->+          nPi' "j" primIntervalType $ \ j  ->           hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->           ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) -->           ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) -->-          (pPi' "o" (imax i j) $ \ o -> el' a $ bA <..> o)+          pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o)   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do     case ts of      [l,i,j,a,u,v] -> do@@ -261,30 +263,30 @@  primPartial' :: TCM PrimitiveImpl primPartial' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       (hPi' "a" (el $ cl primLevel) $ \ a ->-        nPi' "φ" (elInf (cl primInterval)) $ \ _ ->+       hPi' "a" (el $ cl primLevel) (\ a ->+        nPi' "φ" primIntervalType $ \ _ ->         nPi' "A" (sort . tmSort <$> a) $ \ bA ->-        return (sort $ Inf))+        (sort . tmSSort <$> a))   isOne <- primIsOne   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ ts -> do     case ts of       [l,phi,a] -> do           (El s (Pi d b)) <- runNamesT [] $ do                              [l,a,phi] <- mapM (open . unArg) [l,a,phi]-                             (elInf $ pure isOne <@> phi) --> el' l a+                             elSSet (pure isOne <@> phi) --> el' l a           redReturn $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b       _ -> __IMPOSSIBLE__  primPartialP' :: TCM PrimitiveImpl primPartialP' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       (hPi' "a" (el $ cl primLevel) $ \ a ->-        nPi' "φ" (elInf (cl primInterval)) $ \ phi ->+       hPi' "a" (el $ cl primLevel) (\ a ->+        nPi' "φ" primIntervalType $ \ phi ->         nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-        return (sort $ Inf))+        (sort . tmSSort <$> a))   let toFinitePi :: Type -> Term       toFinitePi (El _ (Pi d b)) = Pi (setRelevance Irrelevant $ d { domFinite = True }) b       toFinitePi _               = __IMPOSSIBLE__@@ -292,18 +294,18 @@         lam "a" $ \ l ->         lam "φ" $ \ phi ->         lam "A" $ \ a ->-        toFinitePi <$> nPi' "p" (elInf $ cl primIsOne <@> phi) (\ p -> el' l (a <@> p))+        toFinitePi <$> nPi' "p" (elSSet $ cl primIsOne <@> phi) (\ p -> el' l (a <@> p))   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v  primSubOut' :: TCM PrimitiveImpl primSubOut' = do-  requireCubical+  requireCubical ""   t    <- runNamesT [] $           hPi' "a" (el $ cl primLevel) $ \ a ->           hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-          hPi' "φ" (elInf $ cl primInterval) $ \ phi ->-          hPi' "u" (elInf $ cl primPartial <#> a <@> phi <@> bA) $ \ u ->-          elInf (cl primSub <#> a <@> bA <@> phi <@> u) --> el' (Sort . tmSort <$> a) bA+          hPi' "φ" primIntervalType $ \ phi ->+          hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u ->+          el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do     case ts of       [a,bA,phi,u,x] -> do@@ -321,14 +323,14 @@  primIdFace' :: TCM PrimitiveImpl primIdFace' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $        hPi' "a" (el $ cl primLevel) $ \ a ->        hPi' "A" (sort . tmSort <$> a) $ \ bA ->        hPi' "x" (el' a bA) $ \ x ->        hPi' "y" (el' a bA) $ \ y ->-       (el' a $ cl primId <#> a <#> bA <@> x <@> y)-       --> elInf (cl primInterval)+       el' a (cl primId <#> a <#> bA <@> x <@> y)+       --> primIntervalType   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do     case ts of       [l,bA,x,y,t] -> do@@ -341,14 +343,14 @@  primIdPath' :: TCM PrimitiveImpl primIdPath' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $        hPi' "a" (el $ cl primLevel) $ \ a ->        hPi' "A" (sort . tmSort <$> a) $ \ bA ->        hPi' "x" (el' a bA) $ \ x ->        hPi' "y" (el' a bA) $ \ y ->-       (el' a $ cl primId <#> a <#> bA <@> x <@> y)-       --> (el' a $ cl primPath <#> a <#> bA <@> x <@> y)+       el' a (cl primId <#> a <#> bA <@> x <@> y)+       --> el' a (cl primPath <#> a <#> bA <@> x <@> y)   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do     case ts of       [l,bA,x,y,t] -> do@@ -362,23 +364,23 @@  primTrans' :: TCM PrimitiveImpl primTrans' = do-  requireCubical+  requireCubical ""   t    <- runNamesT [] $-          hPi' "a" (elInf (cl primInterval) --> (el $ cl primLevel)) $ \ a ->-          nPi' "A" (nPi' "i" (elInf (cl primInterval)) $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->-          nPi' "φ" (elInf $ cl primInterval) $ \ phi ->+          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->+          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->+          nPi' "φ" primIntervalType $ \ phi ->           (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))   return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ ts nelims -> do     primTransHComp DoTransp ts nelims  primHComp' :: TCM PrimitiveImpl primHComp' = do-  requireCubical+  requireCubical ""   t    <- runNamesT [] $           hPi' "a" (el $ cl primLevel) $ \ a ->           hPi' "A" (sort . tmSort <$> a) $ \ bA ->-          hPi' "φ" (elInf $ cl primInterval) $ \ phi ->-          (nPi' "i" (elInf $ cl primInterval) $ \ i -> pPi' "o" phi $ \ _ -> el' a bA) -->+          hPi' "φ" primIntervalType $ \ phi ->+          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) -->           (el' a bA --> el' a bA)   return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do     primTransHComp DoHComp ts nelims@@ -422,26 +424,25 @@   iz      <- getTermLocal builtinIZero   let ineg j = pure tINeg <@> j       imax i j = pure tIMax <@> i <@> j-      imin i j = pure tIMin <@> i <@> j-  let forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))-                                      <@> (lam "i" $ \ i -> bA <@> (i `imax` r))+  let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))+                                      <@> lam "i" (\ i -> bA <@> (i `imax` r))                                       <@> r                                       <@> u   return $ \ la bA phi u u0 ->     pure tHComp <#> (la <@> pure io)                 <#> (bA <@> pure io)                 <#> imax phi (ineg phi)-                <@> (lam "i" $ \ i ->+                <@> lam "i" (\ i ->                       pure tPOr <#> (la <@> i)                                 <@> phi                                 <@> ineg phi-                                <@> (ilam "o" $ \ a -> bA <@> i)-                                <@> (ilam "o" $ \ o -> forward la bA i (u <@> i <..> o))-                                <@> (ilam "o" $ \ o -> forward la bA (pure iz) u0))+                                <@> ilam "o" (\ a -> bA <@> i)+                                <@> ilam "o" (\ o -> forward la bA i (u <@> i <..> o))+                                <@> ilam "o" (\ o -> forward la bA (pure iz) u0))                 <@> forward la bA (pure iz) u0  -unglueTranspGlue :: (HasConstInfo m, MonadReduce m, HasBuiltins m) =>+unglueTranspGlue :: PureTCM m =>                   Arg Term                   -> Arg Term                   -> FamilyOrNot@@ -477,18 +478,18 @@         gcomp <- mkGComp localUse          let transpFill la bA phi u0 i =-              pure tTrans <#> (ilam "j" $ \ j -> la <@> imin i j)-                          <@> (ilam "j" $ \ j -> bA <@> imin i j)+              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)+                          <@> ilam "j" (\ j -> bA <@> imin i j)                           <@> (imax phi (ineg i))                           <@> u0         [psi,u0] <- mapM (open . unArg) [psi,u0]         glue1 <- do-          g <- open $ (tglue `apply`) . map (setHiding Hidden) . map (subst 0 io) $ [la, lb, bA, phi, bT, e]+          g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]           return $ \ t a -> g <@> t <@> a         unglue0 <- do-          ug <- open $ (tunglue `apply`) . map (setHiding Hidden) . map (subst 0 iz) $ [la, lb, bA, phi, bT, e]+          ug <- open $ (tunglue `apply`) . map ((setHiding Hidden) . (subst 0 iz)) $ [la, lb, bA, phi, bT, e]           return $ \ a -> ug <@> a-        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ (lam "i" $ const (pure $ unArg a))) [la, lb, bA, phi, bT, e]+        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]         view <- intervalView'          -- phi1 <- view <$> (reduce =<< (phi <@> pure io))@@ -507,9 +508,9 @@                  (lam "i" $ \ i -> pure tPOr <#> (la <@> i)                                              <@> psi                                              <@> forallphi-                                             <@> (ilam "o" $ \ a -> bA <@> i)-                                             <@> (ilam "o" $ \ _ -> a0)-                                             <@> (ilam "o" $ \ o -> pure tEFun <#> (lb <@> i)+                                             <@> ilam "o" (\ a -> bA <@> i)+                                             <@> ilam "o" (\ _ -> a0)+                                             <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i)                                                                                <#> (la <@> i)                                                                                <#> (bT <@> i <..> o)                                                                                <#> (bA <@> i)@@ -528,7 +529,7 @@             (pure (Def (sigmaName kit) []) <#> la                                            <#> lb                                            <@> bA-                                           <@> (lam "a" $ \ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))+                                           <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))            -- We don't have to do anything special for "~ forall. phi"           -- here (to implement "ghcomp") as it is taken care off by@@ -537,12 +538,12 @@             pure tPOr <#> max (la <@> pure io) (lb <@> pure io)                       <@> psi                       <@> forallphi-                      <@> (ilam "o" $ \ _ ->+                      <@> ilam "o" (\ _ ->                              fiber (lb <@> pure io) (la <@> pure io)                                    (bT <@> (pure io) <..> o) (bA <@> pure io)                                    (w (pure io) o) a1)-                      <@> (ilam "o" $ \ o -> sigCon u0 (lam "_" $ \ _ -> a1))-                      <@> (ilam "o" $ \ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))+                      <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1))+                      <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))            -- "ghcomp" is implemented in the proof of tEProof           -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)@@ -563,11 +564,10 @@                   <#> (la <@> pure io)                   <#> (bA <@> pure io)                   <#> (imax (phi <@> pure io) psi)-                  <@> (lam "j" $ \ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> (ilam "o" $ \ _ -> bA <@> pure io)-                                   <@> (ilam "o" $ \ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> (ilam "o" $ \ _ -> a1)-                      )+                  <@> lam "j" (\ j ->+                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)+                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))+                                   <@> ilam "o" (\ _ -> a1))                   <@> a1         -- glue1 (ilam "o" t1') a1'         a1'@@ -575,15 +575,14 @@  data TermPosition = Head | Eliminated deriving (Eq,Show) -headStop :: (HasBuiltins m, MonadReduce m) =>-                  TermPosition -> m Term -> m Bool+headStop :: PureTCM m => TermPosition -> m Term -> m Bool headStop tpos phi   | Head <- tpos = do       phi <- intervalView =<< (reduce =<< phi)       return $ not $ isIOne phi   | otherwise = return False -compGlue :: (MonadReduce m, HasConstInfo m, HasBuiltins m) =>+compGlue :: PureTCM m =>                   TranspOrHComp                   -> Arg Term                   -> Maybe (Arg Term)@@ -614,18 +613,16 @@           hfill la bA phi u u0 i = pure tHComp <#> la                                                <#> bA                                                <#> (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               <@> (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> (ilam "o" $ \ a -> bA)-                                                     <@> (ilam "o" $ \ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> (ilam "o" $ \ _ -> u0)-                                                   )+                                               <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA)+                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)+                                                     <@> ilam "o" (\ _ -> u0))                                                <@> u0           tf i o = hfill lb (bT <..> o) psi u u0 i           unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g           a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi)-                           <@> (lam "i" $ \ i -> pure tPOr <#> la <@> psi <@> phi <@> (ilam "_" $ \ _ -> bA)-                                 <@> (ilam "o" $ \ o -> unglue (u <@> i <..> o))-                                 <@> (ilam "o" $ \ o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o)-                               )+                           <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA)+                                 <@> ilam "o" (\ o -> unglue (u <@> i <..> o))+                                 <@> ilam "o" (\ o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o))                            <@> (unglue u0)           t1 = tf (pure io)         -- pure tglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> (ilam "o" $ \ o -> t1 o) <@> a1@@ -662,18 +659,18 @@         gcomp <- mkGComp localUse          let transpFill la bA phi u0 i =-              pure tTrans <#> (ilam "j" $ \ j -> la <@> imin i j)-                          <@> (ilam "j" $ \ j -> bA <@> imin i j)+              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)+                          <@> ilam "j" (\ j -> bA <@> imin i j)                           <@> (imax phi (ineg i))                           <@> u0         [psi,u0] <- mapM (open . unArg) [psi,u0]         glue1 <- do-          g <- open $ (tglue `apply`) . map (setHiding Hidden) . map (subst 0 io) $ [la, lb, bA, phi, bT, e]+          g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]           return $ \ t a -> g <@> t <@> a         unglue0 <- do-          ug <- open $ (tunglue `apply`) . map (setHiding Hidden) . map (subst 0 iz) $ [la, lb, bA, phi, bT, e]+          ug <- open $ (tunglue `apply`) . map ((setHiding Hidden) . (subst 0 iz)) $ [la, lb, bA, phi, bT, e]           return $ \ a -> ug <@> a-        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ (lam "i" $ const (pure $ unArg a))) [la, lb, bA, phi, bT, e]+        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]         view <- intervalView'          ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do@@ -691,9 +688,9 @@                  (lam "i" $ \ i -> pure tPOr <#> (la <@> i)                                              <@> psi                                              <@> forallphi-                                             <@> (ilam "o" $ \ a -> bA <@> i)-                                             <@> (ilam "o" $ \ _ -> a0)-                                             <@> (ilam "o" $ \ o -> pure tEFun <#> (lb <@> i)+                                             <@> ilam "o" (\ a -> bA <@> i)+                                             <@> ilam "o" (\ _ -> a0)+                                             <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i)                                                                                <#> (la <@> i)                                                                                <#> (bT <@> i <..> o)                                                                                <#> (bA <@> i)@@ -712,7 +709,7 @@             (pure (Def (sigmaName kit) []) <#> la                                            <#> lb                                            <@> bA-                                           <@> (lam "a" $ \ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))+                                           <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))            -- We don't have to do anything special for "~ forall. phi"           -- here (to implement "ghcomp") as it is taken care off by@@ -721,12 +718,12 @@             pure tPOr <#> max (la <@> pure io) (lb <@> pure io)                       <@> psi                       <@> forallphi-                      <@> (ilam "o" $ \ _ ->+                      <@> ilam "o" (\ _ ->                              fiber (lb <@> pure io) (la <@> pure io)                                    (bT <@> (pure io) <..> o) (bA <@> pure io)                                    (w (pure io) o) a1)-                      <@> (ilam "o" $ \ o -> sigCon u0 (lam "_" $ \ _ -> a1))-                      <@> (ilam "o" $ \ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))+                      <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1))+                      <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))            -- "ghcomp" is implemented in the proof of tEProof           -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)@@ -747,11 +744,10 @@                   <#> (la <@> pure io)                   <#> (bA <@> pure io)                   <#> (imax (phi <@> pure io) psi)-                  <@> (lam "j" $ \ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> (ilam "o" $ \ _ -> bA <@> pure io)-                                   <@> (ilam "o" $ \ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> (ilam "o" $ \ _ -> a1)-                      )+                  <@> lam "j" (\ j ->+                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)+                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))+                                   <@> ilam "o" (\ _ -> a1))                   <@> a1          -- glue1 (ilam "o" t1') a1'@@ -760,7 +756,7 @@           Eliminated -> a1' compGlue cmd phi u u0 _ _ = __IMPOSSIBLE__ -compHCompU :: (MonadReduce m, HasConstInfo m, HasBuiltins m) =>+compHCompU :: PureTCM m =>                     TranspOrHComp                     -> Arg Term                     -> Maybe (Arg Term)@@ -794,20 +790,18 @@           hfill la bA phi u u0 i = pure tHComp <#> la                                                <#> bA                                                <#> (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               <@> (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> (ilam "o" $ \ a -> bA)-                                                     <@> (ilam "o" $ \ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> (ilam "o" $ \ _ -> u0)-                                                   )+                                               <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA)+                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)+                                                     <@> ilam "o" (\ _ -> u0))                                                <@> u0-          transp la bA a0 = pure tTransp <#> (lam "i" $ const la) <@> lam "i" bA <@> pure iz <@> a0+          transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0           tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i           bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA           unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g           a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi)-                           <@> (lam "i" $ \ i -> pure tPOr <#> la <@> psi <@> phi <@> (ilam "_" $ \ _ -> bA)-                                 <@> (ilam "o" $ \ o -> unglue (u <@> i <..> o))-                                 <@> (ilam "o" $ \ o -> transp la (\ i -> bT <@> (pure tINeg <@> i) <..> o) (tf i o))-                               )+                           <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA)+                                 <@> ilam "o" (\ o -> unglue (u <@> i <..> o))+                                 <@> ilam "o" (\ o -> transp la (\ i -> bT <@> (pure tINeg <@> i) <..> o) (tf i o)))                            <@> unglue u0           t1 = tf (pure io) @@ -841,13 +835,13 @@         let ineg j = pure tINeg <@> j             imax i j = pure tIMax <@> i <@> j             imin i j = pure tIMin <@> i <@> j-            transp la bA a0 = pure tTrans <#> (lam "i" $ const la) <@> lam "i" bA <@> pure iz <@> a0+            transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0          gcomp <- mkGComp localUse          let transpFill la bA phi u0 i =-              pure tTrans <#> (ilam "j" $ \ j -> la <@> imin i j)-                          <@> (ilam "j" $ \ j -> bA <@> imin i j)+              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)+                          <@> ilam "j" (\ j -> bA <@> imin i j)                           <@> (imax phi (ineg i))                           <@> u0         [psi,u0] <- mapM (open . unArg) [psi,u0]@@ -863,7 +857,7 @@           let bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA           ug <- (open =<<) $ pure tunglue <#> la <#> phi <#> bT <#> bAS           return $ \ a -> ug <@> a-        [la, phi, bT, bA] <- mapM (\ a -> open . runNames [] $ (lam "i" $ const (pure $ unArg a))) [la, phi, bT, bA]+        [la, phi, bT, bA] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, phi, bT, bA]          ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do @@ -882,36 +876,30 @@                  (lam "i" $ \ i -> pure tPOr <#> (la <@> i)                                              <@> psi                                              <@> forallphi-                                             <@> (ilam "o" $ \ a -> bA <@> i)-                                             <@> (ilam "o" $ \ _ -> a0)-                                             <@> (ilam "o" $ \ o -> transp (la <@> i)+                                             <@> ilam "o" (\ a -> bA <@> i)+                                             <@> ilam "o" (\ _ -> a0)+                                             <@> ilam "o" (\ o -> transp (la <@> i)                                                                            (\ j -> bT <@> i <@> ineg j <..> o)                                                                            (tf i o)))                  a0 -          sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y           w i o = lam "x" $                   transp (la <@> i)                          (\ j -> bT <@> i <@> ineg j <..> o)-          fiber la lb bA bB f b =-            (pure (Def (sigmaName kit) []) <#> la-                                           <#> lb-                                           <@> bA-                                           <@> (lam "a" $ \ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))            pt o = -- o : [ φ 1 ]             pure tPOr <#> (la <@> pure io)                       <@> psi                       <@> forallphi-                      <@> (ilam "o" $ \ _ -> bT <@> pure io <@> pure io <..> o)-                      <@> (ilam "o" $ \ o -> u0)-                      <@> (ilam "o" $ \ o -> t1 o)+                      <@> ilam "o" (\ _ -> bT <@> pure io <@> pure io <..> o)+                      <@> ilam "o" (\ o -> u0)+                      <@> ilam "o" (\ o -> t1 o)            -- "ghcomp" is implemented in the proof of tTranspProof           -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda)           t1'alpha o = -- o : [ φ 1 ]              pure tTranspProof <#> (la <@> pure io)-                               <@> (lam "i" $ \ i -> bT <@> pure io <@> ineg i <..> o)+                               <@> lam "i" (\ i -> bT <@> pure io <@> ineg i <..> o)                                <@> imax psi forallphi                                <@> pt o                                <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io)@@ -925,11 +913,10 @@                   <#> (la <@> pure io)                   <#> (bA <@> pure io)                   <#> (imax (phi <@> pure io) psi)-                  <@> (lam "j" $ \ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> (ilam "o" $ \ _ -> bA <@> pure io)-                                   <@> (ilam "o" $ \ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> (ilam "o" $ \ _ -> a1)-                      )+                  <@> lam "j" (\ j ->+                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)+                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))+                                   <@> ilam "o" (\ _ -> a1))                   <@> a1          -- glue1 (ilam "o" t1') a1'@@ -977,7 +964,7 @@                                           IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do                                             [l,c] <- mapM (open . unArg) [famThing l, ignoreBlocking sc]                                             lam "i" $ \ i -> clP builtinIsOneEmpty <#> l-                                                                   <#> (ilam "o" $ \ _ -> c)+                                                                   <#> ilam "o" (\ _ -> c)                                           _     -> return (notReduced u)                             -- cmd == DoTransp                      Nothing -> return []@@ -998,7 +985,7 @@                mId   <- getBuiltinName' builtinId                pathV <- pathView'                case famThing t of-                 MetaV m _ -> fallback' (fmap famThing $ Blocked m () *> sbA)+                 MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA)                  -- absName t instead of "i"                  Pi a b | nelims > 0  -> maybe fallback redReturn =<< compPi cmd "i" ((a,b) <$ t) (ignoreBlocking sphi) u u0                         | otherwise -> fallback@@ -1036,8 +1023,7 @@                          | Just as <- allApplyElims es, [] <- recFields r -> compData False (recPars r) cmd l (as <$ t) sbA sphi u u0                      Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons}                        | and [null pcons | DoHComp  <- [cmd]], Just as <- allApplyElims es -> compData (not $ null $ pcons) (pars+ixs) cmd l (as <$ t) sbA sphi u u0-                     -- postulates with no arguments do not need to transport.-                     Axiom{} | [] <- es, DoTransp <- cmd -> redReturn $ unArg u0+                     Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0                      _          -> fallback                   _ -> fallback@@ -1072,12 +1058,19 @@      runNamesT [] $ do       labA <- do         let (x,f) = case ab of-              IsFam (a,_) -> (a, \ a -> runNames [] $ (lam "i" $ const (pure a)))+              IsFam (a,_) -> (a, \ a -> runNames [] $ lam "i" (const (pure a)))               IsNot (a,_) -> (a, id)-        lx <- toLevel' x-        caseMaybe lx (return Nothing) $ \ lx -> Just <$>-          mapM (open . f) [Level lx, unEl . unDom $ x]-      caseMaybe labA (return Nothing) $ \ [la,bA] -> Just <$> do+        s <- reduce $ getSort x+        case s of+          Type lx -> do+            [la,bA] <- mapM (open . f) [Level lx, unEl . unDom $ x]+            pure $ Just $ \ iOrNot phi a0 -> pure tTrans <#> lam "j" (\ j -> la <@> iOrNot j)+                                                         <@> lam "j" (\ j -> bA <@> iOrNot j)+                                                         <@> phi+                                                         <@> a0+          LockUniv -> return $ Just $ \ _ _ a0 -> a0+          _       -> return Nothing+      caseMaybe labA (return Nothing) $ \ trA -> Just <$> do       [phi, u0] <- mapM (open . unArg) [phi, u0]       u <- traverse open (unArg <$> u) @@ -1087,22 +1080,20 @@             bT <- (raise 1 b `absApp`) <$> u1             let v = u1             pure tHComp <#> (Level <$> toLevel bT)-                        <#> (pure $ unEl                      $ bT)+                        <#> pure (unEl                      $ bT)                         <#> phi-                        <@> (lam "i" $ \ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) v)+                        <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) v)                         <@> (gApply (getHiding a) u0 v)           (DoTransp, IsFam (a , b), Nothing) -> do             let v i = do                        let                          iOrNot j = pure tIMax <@> i <@> (pure tINeg <@> j)-                       pure tTrans <#> (lam "j" $ \ j -> la <@> iOrNot j)-                                 <@> (lam "j" $ \ j -> bA <@> iOrNot j)-                                 <@> (pure tIMax <@> phi <@> i)-                                 <@> u1+                       trA iOrNot (pure tIMax <@> phi <@> i)+                                  u1                 -- Γ , u1 : A[i1] , i : I-                bB v = (consS v $ liftS 1 $ raiseS 1) `applySubst` (absBody b {- Γ , i : I , x : A[i] -})+                bB v = consS v (liftS 1 $ raiseS 1) `applySubst` (absBody b {- Γ , i : I , x : A[i] -})                 tLam = Lam defaultArgInfo-            bT <- bind "i" $ \ i -> bB <$> v i+            bT <- bind "i" $ fmap bB . v             -- Γ , u1 : A[i1]             (pure tTrans <#> (tLam <$> traverse (fmap Level . toLevel) bT)                          <@> (pure . tLam $ unEl                      <$> bT)@@ -1127,12 +1118,12 @@            pure tHComp <#> l                        <#> (bA <@> j)                        <#> (phi `imax` (ineg j `imax` j))-                       <@> (lam "i'" $ \ i ->-                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> (lam "_" $ \ _ -> bA <@> i)+                       <@> lam "i'" (\ i ->+                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i)                             in or phi (ineg j `imax` j)-                                          <@> (ilam "o" $ \ o -> u <@> i <..> o <@@> (x, y, j)) -- a0 <@@> (x <@> i, y <@> i, j)-                                          <@> (or (ineg j) j <@> (ilam "_" $ const x)-                                                                  <@> (ilam "_" $ const y)))+                                          <@> ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j)) -- a0 <@@> (x <@> i, y <@> i, j)+                                          <@> (or (ineg j) j <@> ilam "_" (const x)+                                                                  <@> ilam "_" (const y)))                        <@> (u0 <@@> (x, y, j))     compPathP cmd@DoTransp sphi Nothing u0 (IsFam l) (IsFam (bA,x,y)) = do       -- Γ    ⊢ l@@ -1149,29 +1140,29 @@       comp <- do         tHComp <- getTermLocal builtinHComp         tTrans <- getTermLocal builtinTrans-        let forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))-                                            <@> (lam "i" $ \ i -> bA <@> (i `imax` r))+        let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))+                                            <@> lam "i" (\ i -> bA <@> (i `imax` r))                                             <@> r                                             <@> u         return $ \ la bA phi u u0 ->           pure tHComp <#> (la <@> pure io)                       <#> (bA <@> pure io)                       <#> phi-                      <@> (lam "i" $ \ i -> ilam "o" $ \ o ->+                      <@> lam "i" (\ i -> ilam "o" $ \ o ->                               forward la bA i (u <@> i <..> o))                       <@> forward la bA (pure iz) u0       redReturn . runNames [] $ do         [l,u0] <- mapM (open . unArg) [l,u0]         phi      <- open . unArg . ignoreBlocking $ sphi-        [bA, x, y] <- mapM (\ a -> open . runNames [] $ (lam "i" $ const (pure $ unArg a))) [bA, x, y]+        [bA, x, y] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]         lam "j" $ \ j ->           comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j))                       (lam "i'" $ \ i ->-                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> (lam "_" $ \ _ -> bA <@> i <@> j) in+                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i <@> j) in                                        or phi (ineg j `imax` j)-                                          <@> (ilam "o" $ \ o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j))-                                          <@> (or (ineg j) j <@> (ilam "_" $ const (x <@> i))-                                                                  <@> (ilam "_" $ const (y <@> i))))+                                          <@> ilam "o" (\ o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j))+                                          <@> (or (ineg j) j <@> ilam "_" (const (x <@> i))+                                                                  <@> ilam "_" (const (y <@> i))))                       (u0 <@@> (x <@> pure iz, y <@> pure iz, j))     compPathP _ sphi u a0 _ _ = __IMPOSSIBLE__     compId cmd sphi u a0 l bA_x_y = do@@ -1194,7 +1185,6 @@           tPath <- getTermLocal "primIdPath"           tPathType <- getTermLocal builtinPath           runNamesT [] $ do-            let irrInfo = setRelevance Irrelevant defaultArgInfo             let io = pure $ unview IOne                 iz = pure $ unview IZero                 conId = pure $ Def conid []@@ -1212,7 +1202,7 @@             phi      <- open . unArg . ignoreBlocking $ sphi             [bA, x, y] <-               case bA_x_y of-                IsFam (bA,x,y) -> mapM (\ a -> open . runNames [] $ (lam "i" $ const (pure $ unArg a))) [bA, x, y]+                IsFam (bA,x,y) -> mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]                 IsNot (bA,x,y) -> forM [bA,x,y] $ \ a -> open (Lam defaultArgInfo $ NoAbs "_" $ unArg a)             let               eval DoTransp l bA phi _ u0 = pure tTrans <#> l <@> bA <@> phi <@> u0@@ -1220,7 +1210,7 @@                                                        <@> u <@> u0             conId <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)                   <@> (pure tIMin <@> phi-                                  <@> (ilam "o" $ \ o -> pure tFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)+                                  <@> ilam "o" (\ o -> pure tFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)                                                                    <@> (p io o)))                   <@> (eval cmd l                                 (lam "i" $ \ i -> pure tPathType <#> (l <@> i) <#> (bA <@> i) <@> (x <@> i) <@> (y <@> i))@@ -1259,7 +1249,9 @@             (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do                  let u' = listS bs' `applySubst` u                      bs' = (Map.toAscList $ Map.map boolToI bs)-                 let weaken = foldr composeS idS $ map (\ j -> liftS j (raiseS 1)) $ map fst bs'+                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]+                     -- ordering of "j,i,.." matters.+                 let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs')                  t <- reduce2Lam u'                  return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ])             return $ (flags,t_alphas)@@ -1286,7 +1278,6 @@       unview <- intervalUnview'       let f = unArg . ignoreBlocking           phi = f sphi-          u = f su           a0 = f sa0           isLit t@(Lit lt) = Just t           isLit _ = Nothing@@ -1295,8 +1286,8 @@           combine l ty d [] = d           combine l ty d [(psi,u)] = u           combine l ty d ((psi,u):xs)-            = pure tPOr <#> l <@> psi <@> (foldr imax iz (map fst xs))-                        <#> (ilam "o" $ \ _ -> ty) -- the type+            = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs+                        <#> ilam "o" (\ _ -> ty) -- the type                         <@> u <@> (combine l ty d xs)           noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0]             where@@ -1304,7 +1295,7 @@                      IZero -> notBlocked $ argN $ runNames [] $ do                                  [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]                                  lam "i" $ \ i -> pure tEmpty <#> l-                                                              <#> (ilam "o" $ \ _ -> c)+                                                              <#> ilam "o" (\ _ -> c)                      _     -> su           sameConHeadBack Nothing Nothing su k = noRed' su           sameConHeadBack lt h su k = do@@ -1321,7 +1312,7 @@               let                 phis :: [Term]                 phis = for bools $ \ m ->-                            foldr iMin iO $ map (\(i,b) -> if b then var i else iNeg (var i)) $ Map.toList m+                            foldr (iMin . (\(i,b) -> if b then var i else iNeg (var i))) iO (Map.toList m)               runNamesT [] $ do                 u <- open u                 [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]@@ -1369,25 +1360,24 @@            transp <- getTermLocal builtinTrans            io <- getTermLocal builtinIOne            iz <- getTermLocal builtinIZero-           (redReturn =<<) . runNamesT [] $ do+           redReturn <=< runNamesT [] $ do              [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0]              -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)              pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi-                   <@> (lam "j" $ \ j -> ilam "o" $ \ o ->+                   <@> lam "j" (\ j -> ilam "o" $ \ o ->                         pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o))                    <@> (pure transp <#> l <@> bC <@> phi <@> u0)         _ -> noRed     compData _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__-    compPO = __IMPOSSIBLE__  primComp :: TCM PrimitiveImpl primComp = do-  requireCubical+  requireCubical ""   t    <- runNamesT [] $-          hPi' "a" (elInf (cl primInterval) --> (el $ cl primLevel)) $ \ a ->-          nPi' "A" (nPi' "i" (elInf (cl primInterval)) $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->-          hPi' "φ" (elInf $ cl primInterval) $ \ phi ->-          (nPi' "i" (elInf $ cl primInterval) $ \ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) -->+          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->+          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) -->           (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))   one <- primItIsOne   io  <- primIOne@@ -1405,18 +1395,16 @@             tHComp <- getTermLocal builtinHComp             tTrans <- getTermLocal builtinTrans             iz      <- getTermLocal builtinIZero-            (redReturn =<<) . runNamesT [] $ do+            redReturn <=< runNamesT [] $ do               comp <- do-                let-                  ineg j = (pure tINeg <@> j) :: TCMT IO Term-                  imax i j = pure tIMax <@> i <@> j-                let forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))+                let imax i j = pure tIMax <@> i <@> j+                    forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))                                                     <@> (lam "i" $ \ i -> bA <@> (i `imax` r))                                                     <@> r                                                     <@> u                 return $ \ la bA phi u u0 ->                   pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                              <@> (lam "i" $ \ i -> ilam "o" $ \ o ->+                              <@> lam "i" (\ i -> ilam "o" $ \ o ->                                       forward la bA i (u <@> i <..> o))                               <@> forward la bA (pure iz) u0 @@ -1428,14 +1416,14 @@  prim_glueU' :: TCM PrimitiveImpl prim_glueU' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       (hPi' "la" (el $ cl primLevel) $ \ la ->-       hPi' "φ" (elInf $ cl primInterval) $ \ φ ->-       hPi' "T" (nPi' "i" (elInf $ cl primInterval) $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->-       hPi' "A" (elInf $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->+       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do        let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)-       (pPi' "o" φ $ \ o -> el' la (t <@> cl primIOne <..> o))+       pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o))          --> (el' la bA)          --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA))   view <- intervalView'@@ -1451,12 +1439,12 @@  prim_unglueU' :: TCM PrimitiveImpl prim_unglueU' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       (hPi' "la" (el $ cl primLevel) $ \ la ->-       hPi' "φ" (elInf $ cl primInterval) $ \ φ ->-       hPi' "T" (nPi' "i" (elInf $ cl primInterval) $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->-       hPi' "A" (elInf $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->+       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do        let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)        el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)          --> el' la bA)@@ -1475,10 +1463,10 @@            tTransp <- getTerm builtin_unglueU builtinTrans            iNeg    <- getTerm builtin_unglueU builtinINeg            iZ      <- getTerm builtin_unglueU builtinIZero-           (redReturn =<<) . runNamesT [] $ do+           redReturn <=< runNamesT [] $ do              [la,bT,b] <- mapM (open . unArg) [la,bT,b]-             pure tTransp <#> (lam "i" $ \ _ -> la)-                          <@> (lam "i" $ \ i -> bT <@> (pure iNeg <@> i) <..> pure one)+             pure tTransp <#> lam "i" (\ _ -> la)+                          <@> lam "i" (\ i -> bT <@> (pure iNeg <@> i) <..> pure one)                           <@> pure iZ                           <@> b          _    -> do@@ -1511,16 +1499,16 @@  primGlue' :: TCM PrimitiveImpl primGlue' = do-  requireCubical+  requireCubical ""   -- Glue' : ∀ {l} (A : Set l) → ∀ φ → (T : Partial (Set a) φ) (f : (PartialP φ \ o → (T o) -> A))   --            ([f] : PartialP φ \ o → isEquiv (T o) A (f o)) → Set l   t <- runNamesT [] $-       (hPi' "la" (el $ cl primLevel) $ \ la ->+       hPi' "la" (el $ cl primLevel) (\ la ->        hPi' "lb" (el $ cl primLevel) $ \ lb ->        nPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" (elInf $ cl primInterval) $ \ φ ->+       hPi' "φ" primIntervalType $ \ φ ->        nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a)+       pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a)        --> (sort . tmSort <$> lb))   view <- intervalView'   one <- primItIsOne@@ -1535,15 +1523,15 @@  prim_glue' :: TCM PrimitiveImpl prim_glue' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       (hPi' "la" (el $ cl primLevel) $ \ la ->+       hPi' "la" (el $ cl primLevel) (\ la ->        hPi' "lb" (el $ cl primLevel) $ \ lb ->        hPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" (elInf $ cl primInterval) $ \ φ ->+       hPi' "φ" primIntervalType $ \ φ ->        hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->        hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->-       (pPi' "o" φ $ \ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)))+       pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)))   view <- intervalView'   one <- primItIsOne   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ts ->@@ -1557,12 +1545,12 @@  prim_unglue' :: TCM PrimitiveImpl prim_unglue' = do-  requireCubical+  requireCubical ""   t <- runNamesT [] $-       (hPi' "la" (el $ cl primLevel) $ \ la ->+       hPi' "la" (el $ cl primLevel) (\ la ->        hPi' "lb" (el $ cl primLevel) $ \ lb ->        hPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" (elInf $ cl primInterval) $ \ φ ->+       hPi' "φ" primIntervalType $ \ φ ->        hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->        hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->        (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a)@@ -1612,41 +1600,49 @@ -- TODO Andrea: keep reductions that happen under foralls? primFaceForall' :: TCM PrimitiveImpl primFaceForall' = do-  requireCubical-  t <- (elInf primInterval --> elInf primInterval) --> elInf primInterval-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts ->-    case ts of-      [phi] -> do-        sphi <- reduceB' phi-        case unArg $ ignoreBlocking $ sphi of-          Lam _ t -> do-            t <- reduce' t-            case t of-              NoAbs _ t -> redReturn t-              Abs   _ t -> maybe (return $ NoReduction [reduced sphi]) redReturn =<< toFaceMapsPrim t-          _ -> return (NoReduction [reduced sphi])-      _     -> __IMPOSSIBLE__- where-  toFaceMapsPrim t = do-     view   <- intervalView'-     unview <- intervalUnview'-     us'    <- decomposeInterval t-     fr     <- getTerm builtinFaceForall builtinFaceForall-     let-         v = view t-         us = [ map Left (Map.toList bsm) ++ map Right ts-              | (bsm,ts) <- us'-              , 0 `Map.notMember` bsm-              ]-         fm (i,b) = if b then var (i-1) else unview (INeg (argN (var $ i-1)))-         ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t]-         r = Just $ foldr (\ x r -> unview (IMax (argN x) (argN r))) (unview IZero)-                                 (map (foldr (\ x r -> unview (IMin (argN (either fm ffr x)) (argN r))) (unview IOne)) us)-  --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $-     return $-       case us' of-         [(m,[_])] | Map.null m -> Nothing-         v                      -> r+  requireCubical ""+  t <- (primIntervalType --> primIntervalType) --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts -> case ts of+    [phi] -> do+      sphi <- reduceB' phi+      case unArg $ ignoreBlocking $ sphi of+        Lam _ t -> do+          t <- reduce' t+          case t of+            NoAbs _ t -> redReturn t+            Abs _ t ->+              maybe (return $ NoReduction [reduced sphi]) redReturn+                =<< toFaceMapsPrim t+        _ -> return (NoReduction [reduced sphi])+    _ -> __IMPOSSIBLE__+  where+    toFaceMapsPrim t = do+      view <- intervalView'+      unview <- intervalUnview'+      us' <- decomposeInterval t+      fr <- getTerm builtinFaceForall builtinFaceForall+      let v = view t+          us =+            [ map Left (Map.toList bsm) ++ map Right ts+              | (bsm, ts) <- us',+                0 `Map.notMember` bsm+            ]+          fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1)))+          ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t]+          r =+            Just $+              foldr+                ( (\x r -> unview (IMax (argN x) (argN r)))+                    . foldr+                      (\x r -> unview (IMin (argN (either fm ffr x)) (argN r)))+                      (unview IOne)+                )+                (unview IZero)+                us+      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $+      return $ case us' of+        [(m, [_])] | Map.null m -> Nothing+        v -> r  decomposeInterval :: HasBuiltins m => Term -> m [(Map Int Bool,[Term])] decomposeInterval t = do@@ -1692,7 +1688,7 @@   ineg <- liftTCM primINeg   let     noTranspError t = lift . throwError =<< liftTCM (buildClosure t)-    bapp :: (Applicative m, Subst t a) => m (Abs a) -> m t -> m a+    bapp :: (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a     bapp t u = lazyAbsApp <$> t <*> u     gTransp (Just l) t phi a = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a     gTransp Nothing  t phi a = do@@ -1724,10 +1720,10 @@             b' <- open b'             axi <- open axi             gTransp (Just l) b' phi axi-          Inf    ->-            case 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) of-              False -> return axi-              True -> noTranspError b'+          Inf _ n  ->+            if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi+          SSet _  ->+            if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi           _ -> noTranspError b'     lam_i = Lam defaultArgInfo . Abs "i"     go :: Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args@@ -1740,7 +1736,8 @@       -- Γ ⊢ b : t[1], Γ,i ⊢ b : t[i]       (b,bf) <- runNamesT [] $ do         l <- case s of-               Inf -> return Nothing+               SSet _ -> return Nothing+               Inf _ n -> return Nothing                Type l -> Just <$> open (lam_i (Level l))                _ -> noTranspError (Abs "i" (unDom t))         t <- open $ Abs "i" (unDom t)

src/full/Agda/TypeChecking/ProjectionLike.hs view

@@ -133,7 +133,7 @@ --   (Also reduces projections, but they should not be there, --   since Internal is in lambda- and projection-beta-normal form.) ---reduceProjectionLike :: (MonadReduce m, MonadTCEnv m, HasConstInfo m) => Term -> m Term+reduceProjectionLike :: PureTCM m => Term -> m Term 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.@@ -143,6 +143,9 @@                             -- ordinary reduce, only different for Def's     _                -> return v +data ProjEliminator = EvenLone | ButLone | NoPostfix+  deriving Eq+ -- | 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.@@ -156,21 +159,22 @@ --   No precondition. --   Preserves constructorForm, since it really does only something --   on (applications of) projection-like functions.-elimView-  :: (MonadReduce m, MonadTCEnv m, HasConstInfo m)-  => Bool -> Term -> m Term-elimView loneProjToLambda v = do+elimView :: PureTCM m => ProjEliminator -> Term -> m Term+elimView pe v = do   reportSDoc "tc.conv.elim" 30 $ "elimView of " <+> prettyTCM v   v <- reduceProjectionLike v   reportSDoc "tc.conv.elim" 40 $     "elimView (projections reduced) of " <+> prettyTCM v-  pv <- projView v-  case pv of-    NoProjection{}        -> return v-    LoneProjectionLike f ai-      | loneProjToLambda  -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]-      | otherwise         -> return v-    ProjectionView f a es -> (`applyE` (Proj ProjPrefix f : es)) <$> elimView loneProjToLambda (unArg a)+  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)  -- | Which @Def@types are eligible for the principle argument --   of a projection-like function?@@ -185,6 +189,7 @@     GeneralizableVar{} -> False     Function{}    -> False     Primitive{}   -> False+    PrimitiveSort{} -> False     Constructor{} -> __IMPOSSIBLE__     AbstractDefn d -> eligible d       -- Andreas, 2017-08-14, issue #2682:@@ -259,7 +264,7 @@                  funAbstr = ConcreteDef} -> do       ps0 <- filterM validProj $ candidateArgs [] t       reportSLn "tc.proj.like" 30 $ if null ps0 then "  no candidates found"-                                                else "  candidates: " ++ show ps0+                                                else "  candidates: " ++ prettyShow ps0       unless (null ps0) $ do         -- Andreas 2012-09-26: only consider non-recursive functions for proj.like.         -- Issue 700: problems with recursive funs. in term.checker and reduction@@ -319,19 +324,20 @@       reportSLn "tc.proj.like" 30 $ "  mutual functions can't be projections"     Function{funMutual = Nothing} ->       reportSLn "tc.proj.like" 30 $ "  mutuality check has not run yet"-    Axiom          -> reportSLn "tc.proj.like" 30 $ "  not a function, but Axiom"+    Axiom{}        -> reportSLn "tc.proj.like" 30 $ "  not a function, but Axiom"     DataOrRecSig{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but DataOrRecSig"     GeneralizableVar{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but GeneralizableVar"     AbstractDefn{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but AbstractDefn"     Constructor{}  -> reportSLn "tc.proj.like" 30 $ "  not a function, but Constructor"     Datatype{}     -> reportSLn "tc.proj.like" 30 $ "  not a function, but Datatype"     Primitive{}    -> reportSLn "tc.proj.like" 30 $ "  not a function, but Primitive"+    PrimitiveSort{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but PrimitiveSort"     Record{}       -> reportSLn "tc.proj.like" 30 $ "  not a function, but Record"   where-    -- | If the user wrote a record expression as rhs,-    --   the recordExpressionsToCopatterns translation will turn this into copatterns,-    --   violating the conditions of projection-likeness.-    --   Andreas, 2019-07-11, issue #3843.+    -- If the user wrote a record expression as rhs,+    -- the recordExpressionsToCopatterns translation will turn this into copatterns,+    -- violating the conditions of projection-likeness.+    -- Andreas, 2019-07-11, issue #3843.     isRecordExpression :: Term -> Bool     isRecordExpression = \case       Con _ ConORec _ -> True@@ -354,11 +360,11 @@     checkOccurs cls n = all (nonOccur n) cls      nonOccur n cl =-      and [ take n p == [0..n - 1]-          , onlyMatch n ps  -- projection-like functions are only allowed to match on the eliminatee-                            -- otherwise we may end up projecting from constructor applications, in-                            -- which case we can't reconstruct the dropped parameters-          , checkBody m n b ]+        (take n p == [0..n - 1]) &&+        onlyMatch n ps &&  -- projection-like functions are only allowed to match on the eliminatee+                          -- otherwise we may end up projecting from constructor applications, in+                          -- which case we can't reconstruct the dropped parameters+        checkBody m n b       where         Perm _ p = fromMaybe __IMPOSSIBLE__ $ clausePerm cl         ps       = namedClausePats cl

src/full/Agda/TypeChecking/Quote.hs view

@@ -5,10 +5,11 @@ import Control.Monad  import Data.Maybe (fromMaybe)+import qualified Data.Text as T +import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern ( dbPatPerm' ) import Agda.Syntax.Literal import Agda.Syntax.Position @@ -16,18 +17,39 @@ import Agda.TypeChecking.DropArgs import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive.Base+import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute  import Agda.Utils.Impossible import Agda.Utils.FileName+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size +-- | Parse @quote@.+quotedName :: (MonadTCError m, MonadAbsToCon m) => A.Expr -> m QName+quotedName = \case+  A.Var x          -> genericError $ "Cannot quote a variable " ++ prettyShow x+  A.Def x          -> return x+  A.Macro x        -> return x+  A.Proj _o p      -> unambiguous p+  A.Con c          -> unambiguous c+  A.ScopedExpr _ e -> quotedName e+  e -> genericDocError =<< do+    text "Can only quote defined names, but encountered" <+> prettyA e+  where+  unambiguous xs+    | Just x <- getUnambiguous xs = return x+    | otherwise =+        genericError $ "quote: Ambigous name: " ++ prettyShow (unAmbQ xs) + data QuotingKit = QuotingKit   { quoteTermWithKit   :: Term       -> ReduceM Term   , quoteTypeWithKit   :: Type       -> ReduceM Term-  , quoteClauseWithKit :: Clause     -> ReduceM Term   , quoteDomWithKit    :: Dom Type   -> ReduceM Term   , quoteDefnWithKit   :: Definition -> ReduceM Term   , quoteListWithKit   :: forall a. (a -> ReduceM Term) -> [a] -> ReduceM Term@@ -41,6 +63,9 @@   visible         <- primVisible   relevant        <- primRelevant   irrelevant      <- primIrrelevant+  quantity0       <- primQuantity0+  quantityω       <- primQuantityω+  modality        <- primModalityConstructor   nil             <- primNil   cons            <- primCons   abs             <- primAbsAbs@@ -72,6 +97,9 @@   absurdP         <- primAgdaPatAbsurd   set             <- primAgdaSortSet   setLit          <- primAgdaSortLit+  prop            <- primAgdaSortProp+  propLit         <- primAgdaSortPropLit+  inf             <- primAgdaSortInf   unsupportedSort <- primAgdaSortUnsupported   sucLevel        <- primLevelSuc   lub             <- primLevelMax@@ -106,10 +134,21 @@       quoteRelevance Irrelevant = pure irrelevant       quoteRelevance NonStrict  = pure relevant -      -- TODO: quote Quanity+      quoteQuantity :: Quantity -> ReduceM Term+      quoteQuantity (Quantity0 _) = pure quantity0+      quoteQuantity (Quantity1 _) = __IMPOSSIBLE__+      quoteQuantity (Quantityω _) = pure quantityω++      -- TODO: quote Annotation+      quoteModality :: Modality -> ReduceM Term+      quoteModality m =+        modality !@ quoteRelevance (getRelevance m)+                 @@ quoteQuantity  (getQuantity  m)+       quoteArgInfo :: ArgInfo -> ReduceM Term-      quoteArgInfo (ArgInfo h m _ _) =-        arginfo !@ quoteHiding h @@ quoteRelevance (getRelevance m)+      quoteArgInfo (ArgInfo h m _ _ _) =+        arginfo !@ quoteHiding h+                @@ quoteModality m        quoteLit :: Literal -> ReduceM Term       quoteLit l@LitNat{}    = litNat    !@! Lit l@@ -122,15 +161,19 @@        -- We keep no ranges in the quoted term, so the equality on terms       -- is only on the structure.-      quoteSortLevelTerm :: Level -> ReduceM Term-      quoteSortLevelTerm (ClosedLevel n) = setLit !@! Lit (LitNat noRange n)-      quoteSortLevelTerm l               = set !@ quoteTerm (unlevelWithKit lkit l)+      quoteSortLevelTerm :: Term -> Term -> Level -> ReduceM Term+      quoteSortLevelTerm fromLit fromLevel (ClosedLevel n) = fromLit !@! Lit (LitNat n)+      quoteSortLevelTerm fromLit fromLevel l               = fromLevel !@ quoteTerm (unlevelWithKit lkit l)        quoteSort :: Sort -> ReduceM Term-      quoteSort (Type t) = quoteSortLevelTerm t-      quoteSort Prop{}   = pure unsupportedSort-      quoteSort Inf      = pure unsupportedSort+      quoteSort (Type t) = quoteSortLevelTerm setLit set t+      quoteSort (Prop t) = quoteSortLevelTerm propLit prop t+      quoteSort (Inf f n) = case f of+        IsFibrant -> inf !@! Lit (LitNat n)+        IsStrict  -> pure unsupportedSort+      quoteSort SSet{}   = pure unsupportedSort       quoteSort SizeUniv = pure unsupportedSort+      quoteSort LockUniv = pure unsupportedSort       quoteSort PiSort{} = pure unsupportedSort       quoteSort FunSort{} = pure unsupportedSort       quoteSort UnivSort{}   = pure unsupportedSort@@ -142,31 +185,46 @@       quoteType (El _ t) = quoteTerm t        quoteQName :: QName -> ReduceM Term-      quoteQName x = pure $ Lit $ LitQName noRange x+      quoteQName x = pure $ Lit $ LitQName x        quotePats :: [NamedArg DeBruijnPattern] -> ReduceM Term       quotePats ps = list $ map (quoteArg quotePat . fmap namedThing) ps        quotePat :: DeBruijnPattern -> ReduceM Term-      quotePat p-       | patternOrigin p == Just PatOAbsurd = pure absurdP-      quotePat (VarP o x)        = varP !@! quoteString (dbPatVarName x)-      quotePat (DotP _ _)        = pure dotP+      quotePat p@(VarP _ x)+       | patternOrigin p == Just PatOAbsurd = absurdP !@! quoteNat (toInteger $ dbPatVarIndex x)+      quotePat (VarP o x)        = varP !@! quoteNat (toInteger $ dbPatVarIndex x)+      quotePat (DotP _ t)        = dotP !@ quoteTerm t       quotePat (ConP c _ ps)     = conP !@ quoteQName (conName c) @@ quotePats ps       quotePat (LitP _ l)        = litP !@ quoteLit l       quotePat (ProjP _ x)       = projP !@ quoteQName x       quotePat (IApplyP o t u x) = pure unsupported       quotePat DefP{}            = pure unsupported -      quoteClause :: Clause -> ReduceM Term-      quoteClause cl@Clause{namedClausePats = ps, clauseBody = body} =+      quoteClause :: Maybe Projection -> Clause -> ReduceM Term+      quoteClause proj cl@Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body} =         case body of-          Nothing -> absurdClause !@ quotePats ps-          Just b  ->-            let perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm' False ps -- Dot patterns don't count (#2203)-                v    = applySubst (renamingR perm) b-            in normalClause !@ quotePats ps @@ quoteTerm v+          Nothing -> absurdClause !@ quoteTelescope tel @@ quotePats ps'+          Just b  -> normalClause !@ quoteTelescope tel @@ quotePats ps' @@ quoteTerm b+        where+          -- #5128: restore dropped parameters if projection-like+          ps' =+            case proj of+              Nothing -> ps+              Just p  -> pars ++ ps+                where+                  n    = projIndex p - 1+                  pars = map toVar $ take n $ zip (downFrom $ size tel) (telToList tel)+                  toVar (i, d) = argFromDom d <&> \ (x, _) -> unnamed $ I.varP (DBPatVar x i) +      quoteTelescope :: Telescope -> ReduceM Term+      quoteTelescope tel = quoteList quoteTelEntry $ telToList tel+        where+          quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term+          quoteTelEntry dom@Dom{ unDom = (x , t) } = do+            SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+            Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom)+       list :: [ReduceM Term] -> ReduceM Term       list = foldr (\ a as -> cons !@ a @@ as) (pure nil) @@ -176,7 +234,7 @@       quoteDom :: (a -> ReduceM Term) -> Dom a -> ReduceM Term       quoteDom q Dom{domInfo = info, unDom = t} = arg !@ quoteArgInfo info @@ q t -      quoteAbs :: Subst t a => (a -> ReduceM Term) -> Abs a -> ReduceM Term+      quoteAbs :: Subst a => (a -> ReduceM Term) -> Abs a -> ReduceM Term       quoteAbs q (Abs s t)   = abs !@! quoteString s @@ q t       quoteAbs q (NoAbs s t) = abs !@! quoteString s @@ q (raise 1 t) @@ -187,29 +245,32 @@       quoteArgs ts = list (map (quoteArg quoteTerm) ts)        quoteTerm :: Term -> ReduceM Term-      quoteTerm v =+      quoteTerm v = do+        v <- instantiate' v         case unSpine v of           Var n es   ->              let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-             in  var !@! Lit (LitNat noRange $ fromIntegral n) @@ quoteArgs ts+             in  var !@! Lit (LitNat $ fromIntegral n) @@ quoteArgs ts           Lam info t -> lam !@ quoteHiding (getHiding info) @@ quoteAbs quoteTerm t           Def x es   -> do             defn <- getConstInfo x+            r <- isReconstructed             -- #2220: remember to restore dropped parameters             let-              conOrProjPars = defParameters defn+              conOrProjPars = defParameters defn r               ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-              qx Function{ funExtLam = Just (ExtLamInfo m _), funClauses = cs } = do+              qx Function{ funExtLam = Just (ExtLamInfo m False _), funClauses = cs } = do                     -- An extended lambda should not have any extra parameters!                     unless (null conOrProjPars) __IMPOSSIBLE__                     n <- size <$> lookupSection m                     let (pars, args) = splitAt n ts-                    extlam !@ list (map (quoteClause . (`apply` pars)) cs)+                    extlam !@ list (map (quoteClause Nothing . (`apply` pars)) cs)                            @@ list (map (quoteArg quoteTerm) args)-              qx df@Function{ funCompiled = Just Fail, funClauses = [cl] } = do+              qx df@Function{ funExtLam = Just (ExtLamInfo _ True _), funCompiled = Just Fail{}, funClauses = [cl] } = do                     -- See also corresponding code in InternalToAbstract                     let n = length (namedClausePats cl) - 1-                    extlam !@ list [quoteClause $ dropArgs n cl]+                        pars = take n ts+                    extlam !@ list [quoteClause Nothing $ cl `apply` pars ]                            @@ list (drop n $ map (quoteArg quoteTerm) ts)               qx _ = do                 n <- getDefFreeVars x@@ -217,9 +278,10 @@                      @@ list (drop n $ conOrProjPars ++ map (quoteArg quoteTerm) ts)             qx (theDef defn)           Con x ci es | Just ts <- allApplyElims es -> do+            r <- isReconstructed             cDef <- getConstInfo (conName x)             n    <- getDefFreeVars (conName x)-            let args = list $ drop n $ defParameters cDef ++ map (quoteArg quoteTerm) ts+            let args = list $ drop n $ defParameters cDef r ++ map (quoteArg quoteTerm) ts             con !@! quoteConName x @@ args           Con x ci es -> pure unsupported           Pi t u     -> pi !@  quoteDom quoteType t@@ -229,25 +291,27 @@           Sort s     -> sort !@ quoteSort s           MetaV x es -> meta !@! quoteMeta currentFile x @@ quoteArgs vs             where vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-          DontCare{} -> pure unsupported -- could be exposed at some point but we have to take care+          DontCare u -> quoteTerm u           Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s -      defParameters :: Definition -> [ReduceM Term]-      defParameters def = map par hiding+      defParameters :: Definition -> Bool -> [ReduceM Term]+      defParameters def True  = []+      defParameters def False = map par hiding         where           np = case theDef def of                  Constructor{ conPars = np }        -> np                  Function{ funProjection = Just p } -> projIndex p - 1                  _                                  -> 0           TelV tel _ = telView' (defType def)-          hiding     = map (getHiding &&& getRelevance) $ take np $ telToList tel-          par (h, r) = arg !@ (arginfo !@ quoteHiding h @@ quoteRelevance r) @@ pure unsupported+          hiding     = take np $ telToList tel+          par d      = arg !@ quoteArgInfo (domInfo d)+                           @@ pure unsupported        quoteDefn :: Definition -> ReduceM Term       quoteDefn def =         case theDef def of-          Function{funClauses = cs} ->-            agdaDefinitionFunDef !@ quoteList quoteClause cs+          Function{funClauses = cs, funProjection = proj} ->+            agdaDefinitionFunDef !@ quoteList (quoteClause proj) cs           Datatype{dataPars = np, dataCons = cs} ->             agdaDefinitionDataDef !@! quoteNat (fromIntegral np) @@ quoteList (pure . quoteName) cs           Record{recConHead = c, recFields = fs} ->@@ -259,29 +323,30 @@           GeneralizableVar{} -> pure agdaDefinitionPostulate  -- TODO: reflect generalizable vars           AbstractDefn{}-> pure agdaDefinitionPostulate           Primitive{primClauses = cs} | not $ null cs ->-            agdaDefinitionFunDef !@ quoteList quoteClause cs+            agdaDefinitionFunDef !@ quoteList (quoteClause Nothing) cs           Primitive{}   -> pure agdaDefinitionPrimitive+          PrimitiveSort{} -> pure agdaDefinitionPrimitive           Constructor{conData = d} ->             agdaDefinitionDataConstructor !@! quoteName d -  return $ QuotingKit quoteTerm quoteType quoteClause (quoteDom quoteType) quoteDefn quoteList+  return $ QuotingKit quoteTerm quoteType (quoteDom quoteType) quoteDefn quoteList  quoteString :: String -> Term-quoteString = Lit . LitString noRange+quoteString = Lit . LitString . T.pack  quoteName :: QName -> Term-quoteName x = Lit (LitQName noRange x)+quoteName x = Lit (LitQName x)  quoteNat :: Integer -> Term quoteNat n-  | n >= 0    = Lit (LitNat noRange n)+  | n >= 0    = Lit (LitNat n)   | otherwise = __IMPOSSIBLE__  quoteConName :: ConHead -> Term quoteConName = quoteName . conName  quoteMeta :: AbsolutePath -> MetaId -> Term-quoteMeta file = Lit . LitMeta noRange file+quoteMeta file = Lit . LitMeta file  quoteTerm :: Term -> TCM Term quoteTerm v = do

src/full/Agda/TypeChecking/ReconstructParameters.hs view

@@ -6,24 +6,34 @@  module Agda.TypeChecking.ReconstructParameters where +import Data.Maybe import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic  import Agda.TypeChecking.Monad import Agda.TypeChecking.CheckInternal+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Reduce import Agda.TypeChecking.Telescope import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records+import Agda.TypeChecking.Datatypes  import Agda.Utils.Size+import Agda.Utils.Either  import Agda.Utils.Impossible  reconstructParametersInType :: Type -> TCM Type-reconstructParametersInType a =-  traverse (reconstructParameters (sort $ getSort a)) a+reconstructParametersInType = reconstructParametersInType' defaultAction +reconstructParametersInType' :: Action TCM -> Type -> TCM Type+reconstructParametersInType' act a =+  traverse (reconstructParameters' act (sort $ getSort a)) a+ reconstructParametersInTel :: Telescope -> TCM Telescope reconstructParametersInTel EmptyTel = return EmptyTel reconstructParametersInTel (ExtendTel a tel) = do@@ -37,36 +47,126 @@                       <*> traverse (reconstructParameters $ El s $ unArg a) u                       <*> traverse (reconstructParameters $ El s $ unArg a) v reconstructParametersInEqView (OtherType a) = OtherType <$> reconstructParametersInType a+reconstructParametersInEqView (IdiomType a) = IdiomType <$> reconstructParametersInType a  reconstructParameters :: Type -> Term -> TCM Term-reconstructParameters a v = do+reconstructParameters = reconstructParameters' defaultAction++reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term+reconstructParameters' act a v = do   reportSDoc "tc.with.reconstruct" 30 $     sep [ "reconstructing parameters in"         , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]-  v <- checkInternal' (defaultAction{ postAction = reconstruct }) v CmpLeq a+  v <- checkInternal' reconstructAction v CmpLeq a+   reportSDoc "tc.with.reconstruct" 30 $     nest 2 $ "-->" <+> prettyTCM v   return v   where+    reconstructAction = defaultAction{ postAction = reconstruct }+     reconstruct a v = do-      case v of+      reportSDoc "tc.with.reconstruct" 30 $+        sep [ "reconstructing in"+        , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]+      case unSpine v of         Con h ci vs -> do+          hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h)           TelV tel a <- telView a           let under = size tel  -- under-applied when under > 0-          reportSDoc "tc.with.reconstruct" 50 $+          reportSDoc "tc.reconstruct" 50 $             sep [ "reconstructing"                 , nest 2 $ sep [ prettyTCM v <+> ":"                                , nest 2 $ prettyTCM a ] ]           case (unEl a) of             Def d es -> do               Just n <- defParameters <$> getConstInfo d-              let ps = applySubst (strengthenS __IMPOSSIBLE__ under) . take n $ es-              reportSLn "tc.with.reconstruct" 50 $ show n ++ " parameters"-              -- TODO: the reconstructed parameters are not reconstructed recursively!-              return $ Con h ci (ps ++ vs)+              let prePs = applySubst (strengthenS impossible under) . take n $ es+              let hiddenPs = map (Apply . hideAndRelParams) $ fromMaybe __IMPOSSIBLE__ $+                               allApplyElims prePs+              reportSDoc "tc.reconstruct" 50 $ "The hiddenPs are" <+> pretty hiddenPs+              tyCon <- defType <$> getConstInfo (conName hh)+              reportSDoc "tc.reconstruct" 50 $ "Here we start infering spine"+              ((_,Con hh ci psAfterAct),_) <- inferSpine' act tyCon (Con hh ci []) (Con hh ci []) hiddenPs+              ((_,conWithPars),_) <- inferSpine' reconstructAction tyCon (Con hh ci []) (Con hh ci []) psAfterAct+              reportSDoc "tc.reconstruct" 50 $ "The spine has been inferred:" <+> pretty conWithPars+              return $ applyWithoutReversing conWithPars vs             _ -> __IMPOSSIBLE__-        _        -> return v+        _  -> do+          vv <- elimView EvenLone v+          unSpineAndReconstruct a vv+    unSpineAndReconstruct :: Type -> Term -> TCM Term+    unSpineAndReconstruct a v =+      case v of+        Var i vs -> do+          ty <- typeOfBV i+          ctx <- getContextTelescope+          reportSDoc "tc.reconstruct" 50 $ (text ("Var case "++(show i)++" with context")) <+> prettyTCM ctx+          loop ty (Var i) vs+        Def nam vs -> do+          reportSDoc "tc.reconstruct" 50 $ "Def case"+          ty <- defType <$> getConstInfo nam+          loop ty (Def nam) vs+        MetaV id vs -> do+          reportSDoc "tc.reconstruct" 50 $ "MetaVar case"+          ty <- getMetaType id+          loop ty (MetaV id) vs+        _ -> do+          reportSDoc "tc.reconstruct" 50 $ "Another case" <+> pretty v+          return v+    -- @loop ty f vs@ where @ty@ is the type of @f []@ and vs are valid+    -- arguments to something of type @ty@+    loop :: Type -> (Elims -> Term) -> Elims -> TCM Term+    loop ty f = loop' ty f f+    -- We duplicate @f@ because we don't want the parameters to be reconstructed in+    -- type, since it would cause type-checking error when running @checkInternal'@.+    -- The first one @fTe@ is for term, the other one @fTy@ for type.+    loop' ty fTe _   []           = do+      reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> (pretty $ fTe [])+      return $ fTe []+    loop' ty fTe fTy (Apply u:es) = do+      reportSDoc "tc.reconstruct" 50 $ "The type before app is:" <+> pretty ty+      reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (fTe [])+      uu <- dropParameters u+      reportSDoc "tc.reconstruct" 50 $ "The app is:" <+> pretty uu+      ty' <- piApplyM ty uu+      reportSDoc "tc.reconstruct" 50 $ "The type after app is:" <+> pretty ty'+      loop' ty' (fTe . (Apply u :)) (fTy . (Apply uu :)) es+    loop' ty fTe fTy (Proj o p:es) = do+      reportSDoc "tc.reconstruct" 50 $ "The type is:" <+> pretty ty+      reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (fTe [])+      reportSDoc "tc.reconstruct" 50 $ "The proj is:" <+> prettyTCM p+      ty' <- reduce ty+      case unEl ty' of+        Def r pars -> do+          ~(Just (El _ (Pi _ b))) <- getDefType p ty'+          tyProj <- defType <$> getConstInfo p+          let reconstructWithoutPostFixing = reconstructAction { elimViewAction = elimView NoPostfix }+          let hiddenPs = map Apply $ mapHide tyProj $ fromMaybe __IMPOSSIBLE__ $+                               allApplyElims pars+          reportSDoc "tc.reconstruct" 50 $ "The params are" <+> pretty hiddenPs+          ((_,Def p psAfterAct),_) <- inferSpine' act tyProj (Def p []) (Def p []) hiddenPs+          ((_,projWithPars),_) <- inferSpine' reconstructWithoutPostFixing tyProj (Def p []) (Def p []) psAfterAct+          reportSDoc "tc.reconstruct" 50 $ "Spine infered" <+> pretty projWithPars+          let fTe' x = applyWithoutReversing projWithPars ((Apply $ defaultArg $ fTe []):x)+          loop' (absApp b (fTy [])) fTe' (fTy . (Proj o p:)) es+        _ -> __IMPOSSIBLE__+    loop' ty _   _   (IApply {}:vs) = __IMPOSSIBLE__ +    applyWithoutReversing :: Term -> Elims -> Term+    applyWithoutReversing (Var i es)   ess = Var i (es++ess)+    applyWithoutReversing (Def n es)   ess = Def n (es++ess)+    applyWithoutReversing (Con h i es) ess = Con h i (es++ess)+    applyWithoutReversing (MetaV i es) ess = MetaV i (es++ess)+    applyWithoutReversing (Dummy s es) ess = Dummy s (es++ess)+    applyWithoutReversing _            _   = __IMPOSSIBLE__++    mapHide (El _ (Pi a b)) (p:tl) =+      case argInfoHiding (domInfo a) of+        Hidden -> (hideAndRelParams p):(mapHide (unAbs b) tl)+        _      -> p:(mapHide (unAbs b) tl)+    mapHide t l = l+ dropParameters :: TermLike a => a -> TCM a dropParameters = traverseTermM dropPars   where@@ -76,4 +176,9 @@           Constructor{ conData = d } <- theDef <$> getConstInfo (conName c)           Just n <- defParameters <$> getConstInfo d           return $ Con c ci $ drop n vs+        Def f vs -> do+          isProj <- isProjection f+          case isProj of+            Nothing -> return v+            Just pr -> return $ applyE (projDropPars pr ProjSystem) vs         _        -> return v

src/full/Agda/TypeChecking/RecordPatterns.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Code which replaces pattern matching on record constructors with -- uses of projection functions.@@ -37,7 +36,6 @@  import Agda.Utils.Either import Agda.Utils.Functor-import Agda.Utils.Maybe import Agda.Utils.Permutation hiding (dropFrom) import Agda.Utils.Pretty (Pretty(..)) import qualified Agda.Utils.Pretty as P@@ -59,7 +57,7 @@ recordPatternToProjections :: DeBruijnPattern -> TCM [Term -> Term] recordPatternToProjections p =   case p of-    VarP{}       -> return [ \ x -> x ]+    VarP{}       -> return [ id ]     LitP{}       -> typeError $ ShouldBeRecordPattern p     DotP{}       -> typeError $ ShouldBeRecordPattern p     ConP c ci ps -> do@@ -123,7 +121,7 @@ getEtaAndArity (SplitCon c) =   for (getConstructorInfo c) $ \case     DataCon n        -> (False, n)-    RecordCon eta fs -> (eta == YesEta, size fs)+    RecordCon _ eta fs -> (eta == YesEta, size fs) getEtaAndArity (SplitLit l) = return (False, 0) getEtaAndArity SplitCatchall = return (False, 1) @@ -150,12 +148,12 @@      loop :: CompiledClauses -> m (CompiledClauses)     loop cc = case cc of-      Fail      -> return cc+      Fail{}    -> return cc       Done{}    -> return cc       Case i cs -> loops i cs -    loops :: Arg Int              -- ^ split variable-          -> Case CompiledClauses -- ^ original split tree+    loops :: Arg Int               -- split variable+          -> Case CompiledClauses  -- original split tree           -> m CompiledClauses     loops i cs@Branches{ projPatterns   = comatch                        , conBranches    = conMap@@ -169,18 +167,17 @@       litMap   <- traverse loop litMap       (conMap, eta) <- do         let noEtaCase = (, Nothing) <$> (traverse . traverse) loop conMap-            yesEtaCase ch b = (Map.empty,) . Just . (ch,) <$> traverse loop b+            yesEtaCase b ch = (Map.empty,) . Just . (ch,) <$> traverse loop b         case Map.toList conMap of               -- This is already an eta match. Still need to recurse though.               -- This can happen (#2981) when we               -- 'revisitRecordPatternTranslation' in Rules.Decl, due to               -- inferred eta.-          _ | Just (ch, b) <- eta -> yesEtaCase ch b+          _ | Just (ch, b) <- eta -> yesEtaCase b ch           [(c, b)] | not comatch -> -- possible eta-match             getConstructorInfo c >>= \ case-              RecordCon YesEta fs ->-                let ch = ConHead c Inductive (map argFromDom fs) in-                yesEtaCase ch b+              RecordCon pm YesEta fs -> yesEtaCase b $+                ConHead c (IsRecord pm) Inductive (map argFromDom fs)               _ -> noEtaCase           _ -> noEtaCase       return $ Case i cs{ conBranches    = conMap@@ -214,13 +211,13 @@   -> m CompiledClauses recordExpressionsToCopatterns = \case     Case i bs -> Case i <$> traverse recordExpressionsToCopatterns bs-    cc@Fail   -> return cc+    cc@Fail{} -> return cc     cc@(Done xs (Con c ConORec es)) -> do  -- don't translate if using the record /constructor/       let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es       Constructor{ conArity = ar } <- theDef <$> getConstInfo (conName c)       irrProj <- optIrrelevantProjections <$> pragmaOptions       getConstructorInfo (conName c) >>= \ case-        RecordCon YesEta fs+        RecordCon CopatternMatching YesEta fs           | ar <- length fs, ar > 0,                   -- only for eta-records with at least one field             length vs == ar,                           -- where the constructor application is saturated             irrProj || not (any isIrrelevant fs) -> do -- and irrelevant projections (if any) are allowed@@ -325,11 +322,11 @@ --UNUSED Liang-Ting Chen 2019-07-16 ---- | Bottom-up procedure to annotate split tree. --recordSplitTree :: SplitTree -> TCM RecordSplitTree---recordSplitTree t = snd <$> loop t+--recordSplitTree = snd <.> loop --  where -- --    loop :: SplitTree -> TCM ([Bool], RecordSplitTree)---    loop t = case t of+--    loop = \case --      SplittingDone n -> return (replicate n True, SplittingDone n) --      SplitAt i ts    -> do --        (xs, ts) <- loops (unArg i) ts@@ -350,7 +347,7 @@  -- | Bottom-up procedure to record-pattern-translate split tree. translateSplitTree :: SplitTree -> TCM SplitTree-translateSplitTree t = snd <$> loop t+translateSplitTree = snd <.> loop   where      -- @loop t = return (xs, t')@ returns the translated split tree @t'@@@ -358,7 +355,7 @@     --   True  = variable will never be split on in @t'@ (virgin variable)     --   False = variable will be spilt on in @t'@     loop :: SplitTree -> TCM ([Bool], SplitTree)-    loop t = case t of+    loop = \case       SplittingDone n ->         -- start with n virgin variables         return (replicate n True, SplittingDone n)@@ -400,7 +397,7 @@       -- invariant: if record constructor, then exactly one constructor       if x then unless (rs == [True]) __IMPOSSIBLE__       -- else no record constructor-       else unless (or rs == False) __IMPOSSIBLE__+       else when (or rs) __IMPOSSIBLE__       return (x, conjColumns xss, ts)  -- | @dropFrom i n@ drops arguments @j@  with @j < i + n@ and @j >= i@.@@ -409,7 +406,7 @@   dropFrom :: Int -> Int -> a -> a  instance DropFrom (SplitTree' c) where-  dropFrom i n t = case t of+  dropFrom i n = \case     SplittingDone m -> SplittingDone (m - n)     SplitAt x@(Arg ai j) lz ts       | j >= i + n -> SplitAt (Arg ai $ j - n) lz $ dropFrom i n ts@@ -472,7 +469,7 @@        -- Substitution used to convert terms in the old RHS's       -- context to terms in the new RHS's context.-      rhsSubst = mkSub s'+      rhsSubst = mkSub s' -- NB:: Defined but not used        -- Substitution used to convert terms in the old telescope's       -- context to terms in the new RHS's context.@@ -517,7 +514,7 @@        -- Substitution used to convert terms in the new RHS's context       -- to terms in the new telescope's context.-      lhsSubst' = {-'-} renaming __IMPOSSIBLE__ (reverseP newPerm)+      lhsSubst' = renaming impossible (reverseP newPerm)        -- Substitution used to convert terms in the old telescope's       -- context to terms in the new telescope's context.@@ -562,7 +559,7 @@         ]    reportSDoc "tc.lhs.recpat" 10 $-    escapeContext __IMPOSSIBLE__ (size $ clauseTel clause) $ vcat+    escapeContext impossible (size $ clauseTel clause) $ vcat       [ "Translated clause:"       , nest 2 $ vcat         [ "delta =" <+> prettyTCM (clauseTel c)

src/full/Agda/TypeChecking/Records.hs view

@@ -3,13 +3,15 @@ module Agda.TypeChecking.Records where  import Control.Monad+import Control.Monad.Except import Control.Monad.Trans.Maybe+import Control.Monad.Writer +import Data.Bifunctor import qualified Data.List as List import Data.Maybe import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap-import Data.Traversable (traverse)  import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C@@ -21,23 +23,23 @@  import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Pretty as TCM import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad () --instance only import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings  import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike (eligibleForProjectionLike)  import Agda.Utils.Either-import Agda.Utils.Except import Agda.Utils.Functor (for, ($>)) import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Singleton import Agda.Utils.Size  import Agda.Utils.Impossible@@ -47,39 +49,77 @@  -- | Order the fields of a record construction. orderFields-  :: forall a-  .  QName             -- ^ Name of record type (for error message).+  :: forall a . HasRange a+  => QName             -- ^ Name of record type (for error message).   -> (Arg C.Name -> a) -- ^ How to fill a missing field.   -> [Arg C.Name]      -- ^ Field names of the record type.   -> [(C.Name, a)]     -- ^ Provided fields with content in the record expression.-  -> TCM [a]           -- ^ Content arranged in official order.+  -> Writer [RecordFieldWarning] [a]           -- ^ Content arranged in official order. orderFields r fill axs fs = do-  reportSDoc "tc.record" 30 $ vcat-    [ "orderFields"-    , "  official fields: " <+> sep (map pretty xs)-    , "  provided fields: " <+> sep (map pretty ys)-    ]-  unlessNull duplicate $ typeError . DuplicateFields . nubOn id-  unlessNull alien     $ typeError . TooManyFields r missing-  return $ for axs $ \ ax -> fromMaybe (fill ax) $ lookup (unArg ax) fs+  -- reportSDoc "tc.record" 30 $ vcat+  --   [ "orderFields"+  --   , "  official fields: " <+> sep (map pretty xs)+  --   , "  provided fields: " <+> sep (map pretty ys)+  --   ]+  unlessNull alien     $ warn $ TooManyFieldsWarning r missing+  unlessNull duplicate $ warn $ DuplicateFieldsWarning+  return $ for axs $ \ ax -> fromMaybe (fill ax) $ lookup (unArg ax) uniq   where-    xs        = map unArg axs           -- official  fields (accord. record type)-    ys        = map fst fs              -- provided  fields-    duplicate = duplicates ys           -- duplicate fields-    alien     = ys List.\\ xs           -- spurious  fields-    missing   = xs List.\\ ys           -- missing   fields+    (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+    alien     = filter (not . hasElem xs . fst) fs      -- spurious fields+    warn w    = tell . singleton . w . map (second getRange) +-- | Raise generated 'RecordFieldWarning's as warnings.+warnOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a+warnOnRecordFieldWarnings comp = do+  let (res, ws) = runWriter comp+  mapM_ (warning . RecordFieldWarning) ws+  return res++-- | Raise generated 'RecordFieldWarning's as errors.+failOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a+failOnRecordFieldWarnings comp = do+  let (res, ws) = runWriter comp+  mapM_ (typeError . recordFieldWarningToError) ws+    -- This will raise the first warning (if any) as error.+  return res++-- | Order the fields of a record construction.+--   Raise generated 'RecordFieldWarning's as warnings.+orderFieldsWarn+  :: forall a . HasRange a+  => QName             -- ^ Name of record type (for error message).+  -> (Arg C.Name -> a) -- ^ How to fill a missing field.+  -> [Arg C.Name]      -- ^ Field names of the record type.+  -> [(C.Name, a)]     -- ^ Provided fields with content in the record expression.+  -> TCM [a]           -- ^ Content arranged in official order.+orderFieldsWarn r fill axs fs = warnOnRecordFieldWarnings $ orderFields r fill axs fs++-- | Order the fields of a record construction.+--   Raise generated 'RecordFieldWarning's as errors.+orderFieldsFail+  :: forall a . HasRange a+  => QName             -- ^ Name of record type (for error message).+  -> (Arg C.Name -> a) -- ^ How to fill a missing field.+  -> [Arg C.Name]      -- ^ Field names of the record type.+  -> [(C.Name, a)]     -- ^ Provided fields with content in the record expression.+  -> TCM [a]           -- ^ Content arranged in official order.+orderFieldsFail r fill axs fs = failOnRecordFieldWarnings $ orderFields r fill axs fs+ -- | A record field assignment @record{xs = es}@ might not mention all --   visible fields.  @insertMissingFields@ inserts placeholders for --   the missing visible fields and returns the values in order --   of the fields in the record declaration. insertMissingFields-  :: forall a-  .  QName                -- ^ Name of record type (for error reporting).+  :: forall a . HasRange a+  => QName                -- ^ Name of record type (for error reporting).   -> (C.Name -> a)        -- ^ Function to generate a placeholder for missing visible field.   -> [FieldAssignment' a] -- ^ Given fields.   -> [Arg C.Name]         -- ^ All record field names with 'ArgInfo'.-  -> TCM [NamedArg a]     -- ^ Given fields enriched by placeholders for missing explicit fields.+  -> Writer [RecordFieldWarning] [NamedArg a]+       -- ^ Given fields enriched by placeholders for missing explicit fields. insertMissingFields r placeholder fs axs = do   -- Compute the list of given fields, decorated with the ArgInfo from the record def.   let arg x e = caseMaybe (List.find ((x ==) . unArg) axs) (defaultNamedArg e) $ \ a ->@@ -103,10 +143,34 @@       | visible ax = unnamed       | otherwise  = named $ WithOrigin Inserted $ Ranged (getRange ax) $ prettyShow $ unArg ax --- | The name of the module corresponding to a record.-recordModule :: QName -> ModuleName-recordModule = mnameFromList . qnameToList+-- | A record field assignment @record{xs = es}@ might not mention all+--   visible fields.  @insertMissingFields@ inserts placeholders for+--   the missing visible fields and returns the values in order+--   of the fields in the record declaration.+insertMissingFieldsWarn+  :: forall a . HasRange a+  => QName                -- ^ Name of record type (for error reporting).+  -> (C.Name -> a)        -- ^ Function to generate a placeholder for missing visible field.+  -> [FieldAssignment' a] -- ^ Given fields.+  -> [Arg C.Name]         -- ^ All record field names with 'ArgInfo'.+  -> TCM [NamedArg a]     -- ^ Given fields enriched by placeholders for missing explicit fields.+insertMissingFieldsWarn r placeholder fs axs =+  warnOnRecordFieldWarnings $ insertMissingFields r placeholder fs axs +-- | A record field assignment @record{xs = es}@ might not mention all+--   visible fields.  @insertMissingFields@ inserts placeholders for+--   the missing visible fields and returns the values in order+--   of the fields in the record declaration.+insertMissingFieldsFail+  :: forall a . HasRange a+  => QName                -- ^ Name of record type (for error reporting).+  -> (C.Name -> a)        -- ^ Function to generate a placeholder for missing visible field.+  -> [FieldAssignment' a] -- ^ Given fields.+  -> [Arg C.Name]         -- ^ All record field names with 'ArgInfo'.+  -> TCM [NamedArg a]     -- ^ Given fields enriched by placeholders for missing explicit fields.+insertMissingFieldsFail r placeholder fs axs =+  failOnRecordFieldWarnings $ insertMissingFields r placeholder fs axs+ -- | 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 Defn@@ -170,7 +234,7 @@ -- | Returns the given record type's constructor name (with an empty -- range). getRecordConstructor :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead-getRecordConstructor r = killRange <$> recConHead <$> getRecordDef r+getRecordConstructor r = killRange . recConHead <$> getRecordDef r  -- | Check if a name refers to a record. --   If yes, return record definition.@@ -186,16 +250,14 @@ -- | 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 :: (MonadReduce m, HasConstInfo m, HasBuiltins m)-             => Type -> m (Maybe (QName, Args, Defn))+isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, Defn)) 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 :: (MonadReduce m, HasConstInfo m, HasBuiltins m)-              => Type -> m (Either (Blocked Type) (QName, Args, Defn))+tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, Defn)) 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@@ -226,8 +288,7 @@ --   Precondition: @t@ is reduced. -- --   See also: 'Agda.TypeChecking.Datatypes.getConType'-getDefType :: (HasConstInfo m, MonadReduce m, MonadDebug m)-           => QName -> Type -> m (Maybe Type)+getDefType :: PureTCM m => QName -> Type -> m (Maybe Type) getDefType f t = do   -- Andreas, Issue #1973: we need to take the original projection   -- since the parameters from the reduced type t are correct for@@ -240,9 +301,9 @@   -- if @f@ is not a projection (like) function, @a@ is the correct type       fallback = return $ Just a   reportSDoc "tc.deftype" 20 $ vcat-    [ ("definition f = " <> prettyTCM f) <+> text ("  -- raw: " ++ prettyShow f)-    , "has type   a = " <> prettyTCM a-    , "principal  t = " <> prettyTCM t+    [ "definition f =" <+> prettyTCM f <+> text ("  -- raw: " ++ prettyShow f)+    , "has type   a =" <+> prettyTCM a+    , "principal  t =" <+> prettyTCM t     ]   caseMaybe mp fallback $     \ (Projection{ projIndex = n }) -> if n <= 0 then fallback else do@@ -291,8 +352,8 @@ --   Precondition: @t@ is reduced. -- projectTyped-  :: (HasConstInfo m, MonadReduce m, MonadDebug m)-  =>  Term        -- ^ Head (record value).+  :: PureTCM m+  => Term        -- ^ Head (record value).   -> Type        -- ^ Its type.   -> ProjOrigin   -> QName       -- ^ Projection.@@ -314,7 +375,7 @@ instance PrettyTCM ElimType where   prettyTCM (ArgT a)    = prettyTCM a   prettyTCM (ProjT a b) =-    "." <> parens (prettyTCM a <+> "->" <+> prettyTCM b)+    "." TCM.<> parens (prettyTCM a <+> "->" <+> prettyTCM b)  -- | Given a head and its type, compute the types of the eliminations. @@ -350,12 +411,13 @@ -- | Going under one of these does not count as a decrease in size for the termination checker. isEtaOrCoinductiveRecordConstructor :: HasConstInfo m => QName -> m Bool isEtaOrCoinductiveRecordConstructor c =-  caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) ->-    return $ (Just Inductive, NoEta) /= (recInduction def, recEtaEquality def)+  caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) -> return $+    recEtaEquality def == YesEta || recInduction def /= Just Inductive+      -- 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 :: QName -> TCM Bool-isInductiveRecord r = maybe False (\ d -> recInduction d /= Just CoInductive) <$> isRecord r+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)@@ -390,9 +452,9 @@  -- | Turn off eta for unguarded recursive records. --   Projections do not preserve guardedness.-unguardedRecord :: QName -> TCM ()-unguardedRecord q = modifySignature $ updateDefinition q $ updateTheDef $ \case-  r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) NoEta }+unguardedRecord :: QName -> PatternOrCopattern -> TCM ()+unguardedRecord q pat = modifySignature $ updateDefinition q $ updateTheDef $ \case+  r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) $ NoEta pat }   _ -> __IMPOSSIBLE__  -- | Turn on eta for inductive guarded recursive records.@@ -404,7 +466,7 @@     r@Record{ recInduction = ind, recEtaEquality' = eta } ->       r { recEtaEquality' = eta' }       where-      eta' | ok, eta == Inferred NoEta, ind /= Just CoInductive = Inferred YesEta+      eta' | ok, Inferred NoEta{} <- eta, ind /= Just CoInductive = Inferred YesEta            | otherwise = eta     _ -> __IMPOSSIBLE__ @@ -413,7 +475,7 @@ nonRecursiveRecord q = whenM etaEnabled $ do   -- Do nothing if eta is disabled by option.   modifySignature $ updateDefinition q $ updateTheDef $ \case-    r@Record{ recInduction = ind, recEtaEquality' = Inferred NoEta }+    r@Record{ recInduction = ind, recEtaEquality' = Inferred (NoEta _) }       | ind /= Just CoInductive ->       r { recEtaEquality' = Inferred YesEta }     r@Record{} -> r@@ -454,7 +516,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+  let (gamma1, dom@(Dom{domInfo = ai, unDom = (x, a)}) : gamma2) = splitAt l gamma -- TODO:: Defined but not used dom, ai   -- This must be a eta-expandable record type.   let failure = do         reportSDoc "tc.meta.assign.proj" 25 $@@ -462,8 +524,9 @@           " since its type " <+> prettyTCM a <+>           " is not a record type"         return Nothing-  caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> do-    if recEtaEquality def == NoEta then return Nothing else Just <$> do+  caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> case recEtaEquality def of+    NoEta{} -> return Nothing+    YesEta  -> Just <$> do       -- Get the record fields @Γ₁ ⊢ tel@ (@tel = Γ'@).       -- TODO: compose argInfo ai with tel.       let tel = recTel def `apply` pars@@ -531,7 +594,8 @@       -- 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-      when (recEtaEquality def == NoEta) __IMPOSSIBLE__+      if | NoEta _ <- recEtaEquality def -> __IMPOSSIBLE__+         | otherwise -> return ()       -- TODO: compose argInfo ai with tel.       let tel = recTel def `apply` pars           m   = size tel@@ -565,7 +629,7 @@      where @tel@ is the record telescope instantiated at the parameters @pars@. -}-etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m)+etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m)                 => QName -> Args -> Term -> m (Telescope, Args) etaExpandRecord = etaExpandRecord' False @@ -574,10 +638,10 @@                      => QName -> Args -> Term -> m (Telescope, Args) forceEtaExpandRecord = etaExpandRecord' True -etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m)+etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m)                  => Bool -> QName -> Args -> Term -> m (Telescope, Args) etaExpandRecord' forceEta r pars u = do-  def <- getRecordDef r+  def <- fromMaybe __IMPOSSIBLE__ <$> isRecord r   (tel, _, _, args) <- etaExpandRecord'_ forceEta r pars def u   return (tel, args) @@ -661,15 +725,16 @@           -- if @a@ is the record field name applied to a single argument           -- then it passes the check           (_, Just (_, [])) -> Nothing  -- not a projection-          (_, Just (h, es)) | Proj _o f <- last es, unDom ax == f-                            -> Just $ Just $ h $ init es+          (_, Just (h, e0:es0))+            | (es, Proj _o f) <- initLast1 e0 es0+            , unDom ax == f -> Just $ Just $ h es           _                 -> Nothing   case compare (length args) (length xs) of     LT -> fallBack       -- Not fully applied     GT -> __IMPOSSIBLE__ -- Too many arguments. Impossible.     EQ -> do       case zipWithM check args xs of-        Just as -> case [ a | Just a <- as ] of+        Just as -> case catMaybes as of           (a:as) ->             if all (a ==) as               then return a@@ -684,94 +749,88 @@ -- -- Precondition: The name should refer to a record type, and the -- arguments should be the parameters to the type.-isSingletonRecord :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m)-                  => QName -> Args -> m (Either MetaId Bool)-isSingletonRecord r ps = mapRight isJust <$> isSingletonRecord' False r ps+isSingletonRecord :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool+isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps -isSingletonRecordModuloRelevance :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m)-                                 => QName -> Args -> m (Either MetaId Bool)-isSingletonRecordModuloRelevance r ps = mapRight isJust <$> isSingletonRecord' True r ps+isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m)+                                 => QName -> Args -> m Bool+isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps  -- | Return the unique (closed) inhabitant if exists. --   In case of counting irrelevance in, the returned inhabitant --   contains dummy terms.-isSingletonRecord' :: forall m. (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m)-                   => Bool -> QName -> Args -> m (Either MetaId (Maybe Term))+isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m)+                   => Bool -> QName -> Args -> m (Maybe Term) isSingletonRecord' regardIrrelevance r ps = do   reportSDoc "tc.meta.eta" 30 $ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?"   isRecord r >>= \case-    Nothing  -> return $ Right Nothing+    Nothing  -> return Nothing     Just def -> do-      emap (mkCon (recConHead def) ConOSystem) <$> check (recTel def `apply` ps)+      fmap (mkCon (recConHead def) ConOSystem) <$> check (recTel def `apply` ps)   where-  check :: Telescope -> m (Either MetaId (Maybe [Arg Term]))+  check :: Telescope -> m (Maybe [Arg Term])   check tel = do     reportSDoc "tc.meta.eta" 30 $       "isSingletonRecord' checking telescope " <+> prettyTCM tel     case tel of-      EmptyTel -> return $ Right $ Just []+      EmptyTel -> return $ Just []       ExtendTel dom tel -> ifM (return regardIrrelevance `and2M` isIrrelevantOrPropM dom)         {-then-}-          (underAbstraction dom tel $ \ tel ->-            emap (Arg (domInfo dom) __DUMMY_TERM__ :) <$> check tel)+          (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check)         {-else-} $ do           isSing <- isSingletonType' regardIrrelevance $ unDom dom           case isSing of-            Left mid       -> return $ Left mid-            Right Nothing  -> return $ Right Nothing-            Right (Just v) -> underAbstraction dom tel $ \ tel ->-              emap (Arg (domInfo dom) v :) <$> check tel+            Nothing  -> return Nothing+            (Just v) -> underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check  -- | Check whether a type has a unique inhabitant and return it. --   Can be blocked by a metavar.-isSingletonType :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m)-                => Type -> m (Either MetaId (Maybe Term))+isSingletonType :: (PureTCM m, MonadBlock m) => Type -> m (Maybe Term) isSingletonType = isSingletonType' False  -- | Check whether a type has a unique inhabitant (irrelevant parts ignored). --   Can be blocked by a metavar.-isSingletonTypeModuloRelevance :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m)-                               => Type -> m (Either MetaId Bool)-isSingletonTypeModuloRelevance t = mapRight isJust <$> isSingletonType' True t+isSingletonTypeModuloRelevance :: (PureTCM m, MonadBlock m) => Type -> m Bool+isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t -isSingletonType' :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, ReadTCState m)-                 => Bool -> Type -> m (Either MetaId (Maybe Term))+isSingletonType' :: (PureTCM m, MonadBlock m) => Bool -> Type -> m (Maybe Term) isSingletonType' regardIrrelevance t = do     TelV tel t <- telView t-    ifBlocked t (\ m _ -> return $ Left m) $ \ _ t -> addContext tel $ do+    t <- abortIfBlocked t+    addContext tel $ do       res <- isRecordType t       case res of         Just (r, ps, def) | YesEta <- recEtaEquality def -> do-          emap (abstract tel) <$> isSingletonRecord' regardIrrelevance r ps-        _ -> return $ Right Nothing+          fmap (abstract tel) <$> isSingletonRecord' regardIrrelevance r ps+        _ -> return Nothing  -- | Checks whether the given term (of the given type) is beta-eta-equivalent --   to a variable. Returns just the de Bruijn-index of the variable if it is, --   or nothing otherwise.-isEtaVar :: Term -> Type -> TCM (Maybe Int)+isEtaVar :: forall m. PureTCM m => Term -> Type -> m (Maybe Int) isEtaVar u a = runMaybeT $ isEtaVarG u a Nothing []   where     -- Checks whether the term u (of type a) is beta-eta-equivalent to     -- `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 TCM Int+    isEtaVarG :: Term -> Type -> Maybe Int -> [Elim' Int] -> MaybeT m Int     isEtaVarG u a mi es = do-      (u, a) <- liftTCM $ reduce (u, a)-      liftTCM $ reportSDoc "tc.lhs" 80 $ "isEtaVarG" <+> nest 2 (vcat-        [ "u  = " <+> text (show u)+      (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 (text . show) es)+        , "es = " <+> prettyList_ (map (prettyTCM . fmap var) es)         ])       case (u, unEl a) of         (Var i' es', _) -> do           guard $ mi == (i' <$ mi)-          b <- liftTCM $ typeOfBV i'+          b <- typeOfBV i'           areEtaVarElims (var i') b es' es           return i'         (_, Def d pars) -> do-          guard =<< do liftTCM $ isEtaRecord d-          fs <- liftTCM $ map unDom . recFields . theDef <$> getConstInfo d+          guard =<< do isEtaRecord d+          fs <- map unDom . recFields . theDef <$> getConstInfo d           is <- forM fs $ \f -> do             let o = ProjSystem             (_, _, fa) <- MaybeT $ projectTyped u a o f@@ -791,13 +850,13 @@     -- `areEtaVarElims u a es es'` checks whether the given elims es (as applied     -- to the term u of type a) are beta-eta-equal to either projections or     -- variables with de Bruijn indices given by es'.-    areEtaVarElims :: Term -> Type -> Elims -> [Elim' Int] -> MaybeT TCM ()+    areEtaVarElims :: Term -> Type -> Elims -> [Elim' Int] -> MaybeT m ()     areEtaVarElims u a []    []    = return ()     areEtaVarElims u a []    (_:_) = mzero     areEtaVarElims u a (_:_) []    = mzero     areEtaVarElims u a (Proj o f : es) (Proj _ f' : es') = do       guard $ f == f'-      a       <- liftTCM $ reduce a+      a       <- reduce a       (_, _, fa) <- MaybeT $ projectTyped u a o f       areEtaVarElims (u `applyE` [Proj o f]) fa es es'     -- These two cases can occur only when we're looking at two different@@ -816,10 +875,6 @@       _ <- isEtaVarG (unArg v) (unDom dom) (Just $ unArg i) []       areEtaVarElims (u `apply` [fmap var i]) (cod `absApp` var (unArg i)) es es' ---- | Auxiliary function.-emap :: (a -> b) -> Either c (Maybe a) -> Either c (Maybe b)-emap = mapRight . fmap  -- | Replace projection patterns by the original projections. --

src/full/Agda/TypeChecking/Reduce.hs view

@@ -1,17 +1,16 @@ {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE UndecidableInstances     #-}-{-# LANGUAGE TypeFamilies             #-}  module Agda.TypeChecking.Reduce where -import Prelude hiding (mapM)-import Control.Monad.Reader hiding (mapM)+import Control.Monad.Reader -import Data.List ((\\)) import Data.Maybe import Data.Map (Map)+import qualified Data.IntMap as IntMap+import Data.Foldable import Data.Traversable import Data.HashMap.Strict (HashMap)+import qualified Data.Set as Set  import Agda.Interaction.Options @@ -25,7 +24,6 @@ import {-# SOURCE #-} Agda.TypeChecking.Irrelevance (workOnTypes, isPropM) import {-# SOURCE #-} Agda.TypeChecking.Level (reallyUnLevelView) import Agda.TypeChecking.Monad hiding ( enterClosure, constructorForm )-import qualified Agda.TypeChecking.Monad as TCM import Agda.TypeChecking.Substitute import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.EtaContract@@ -40,9 +38,11 @@  import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.Maybe import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad+import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.Tuple import qualified Agda.Utils.SmallSet as SmallSet@@ -61,6 +61,21 @@ reduceB :: (Reduce a, MonadReduce m) => a -> m (Blocked a) reduceB = liftReduce . reduceB' +-- Reduce a term and also produce a blocker signifying when+-- this reduction should be retried.+reduceWithBlocker :: (Reduce a, IsMeta a, MonadReduce m) => a -> m (Blocker, a)+reduceWithBlocker a = ifBlocked a+  (\b a' -> return (b, a'))+  (\_ a' -> return (neverUnblock, a'))++-- Reduce a term and call the continuation. If the continuation is+-- blocked, the whole call is blocked either on what blocked the reduction+-- or on what blocked the continuation (using `blockedOnEither`).+withReduced+  :: (Reduce a, IsMeta a, MonadReduce m, MonadBlock m)+  => a -> (a -> m b) -> m b+withReduced a cont = ifBlocked a (\b a' -> addOrUnblocker b $ cont a') (\_ a' -> cont a')+ normalise :: (Normalise a, MonadReduce m) => a -> m a normalise = liftReduce . normalise' @@ -80,6 +95,22 @@     InstV _tel v -> noMetas <$> instantiateFull v     _ -> return False +-- | Blocking on all blockers.+blockAll :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)+blockAll bs = blockedOn block $ fmap ignoreBlocking bs+  where block = unblockOnAll $ foldMap (Set.singleton . blocker) bs+        blocker NotBlocked{}  = alwaysUnblock+        blocker (Blocked b _) = b++-- | Blocking on any blockers.+blockAny :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)+blockAny bs = blockedOn block $ fmap ignoreBlocking bs+  where block = case foldMap blocker bs of+                  [] -> alwaysUnblock -- no blockers+                  bs -> unblockOnAny $ Set.fromList bs+        blocker NotBlocked{}  = []+        blocker (Blocked b _) = [b]+ -- | Instantiate something. --   Results in an open meta variable or a non meta. --   Doesn't do any reduction, and preserves blocking tags (when blocking meta@@ -99,6 +130,7 @@ instance Instantiate t => Instantiate (Arg t) instance Instantiate t => Instantiate (Elim' t) instance Instantiate t => Instantiate (Tele t)+instance Instantiate t => Instantiate (IPBoundary' t)  instance (Instantiate a, Instantiate b) => Instantiate (a,b) where     instantiate' (x,y) = (,) <$> instantiate' x <*> instantiate' y@@ -111,7 +143,7 @@     blocking <- view stInstantiateBlocking <$> getTCState      mv <- lookupMeta x-    mi <- mvInstantiation <$> pure mv+    let mi = mvInstantiation mv      case mi of       InstV tel v -> instantiate' inst@@ -133,7 +165,7 @@       OpenInstance                     -> return t       BlockedConst u | blocking  -> instantiate' . unBrave $ BraveTerm u `applyE` es                      | otherwise -> return t-      PostponedTypeCheckingProblem _ _ -> return t+      PostponedTypeCheckingProblem _ -> return t   instantiate' (Level l) = levelTm <$> instantiate' l   instantiate' (Sort s) = Sort <$> instantiate' s   instantiate' t = return t@@ -144,40 +176,30 @@ instance Instantiate Level where   instantiate' (Max m as) = levelMax m <$> instantiate' as --- Note: since @PlusLevel' t@ embeds a @LevelAtom' t@, simply--- using @traverse@ for @PlusLevel'@ would not be not correct.-instance Instantiate PlusLevel where-  instantiate' (Plus n a) = Plus n <$> instantiate' a--instance Instantiate LevelAtom where-  instantiate' l = case l of-    MetaLevel m vs -> do-      v <- instantiate' (MetaV m vs)-      case v of-        MetaV m vs -> return $ MetaLevel m vs-        _          -> return $ UnreducedLevel v-    UnreducedLevel l -> UnreducedLevel <$> instantiate' l-    _ -> return l+-- Use Traversable instance+instance Instantiate t => Instantiate (PlusLevel' t)  instance Instantiate a => Instantiate (Blocked a) where   instantiate' v@NotBlocked{} = return v-  instantiate' v@(Blocked x u) = do-    mi <- mvInstantiation <$> lookupMeta x-    case mi of-      InstV{}                        -> notBlocked <$> instantiate' u-      Open                           -> return v-      OpenInstance                   -> return v-      BlockedConst{}                 -> return v-      PostponedTypeCheckingProblem{} -> return v+  instantiate' v@(Blocked b u) = instantiate' b >>= \ case+    b | b == alwaysUnblock -> notBlocked <$> instantiate' u+      | otherwise          -> return $ Blocked b u +instance Instantiate Blocker where+  instantiate' (UnblockOnAll bs) = unblockOnAll . Set.fromList <$> mapM instantiate' (Set.toList bs)+  instantiate' (UnblockOnAny bs) = unblockOnAny . Set.fromList <$> mapM instantiate' (Set.toList bs)+  instantiate' b@(UnblockOnMeta x) =+    ifM (isInstantiatedMeta x) (return alwaysUnblock) (return b)+  instantiate' b@UnblockOnProblem{} = return b+ instance Instantiate Sort where-  instantiate' s = case s of+  instantiate' = \case     MetaS x es -> instantiate' (MetaV x es) >>= \case       Sort s'      -> return s'       MetaV x' es' -> return $ MetaS x' es'-      Def d es'     -> return $ DefS d es'+      Def d es'    -> return $ DefS d es'       _            -> __IMPOSSIBLE__-    _ -> return s+    s -> return s  instance (Instantiate t, Instantiate e) => Instantiate (Dom' t e) where     instantiate' (Dom i fin n tac x) = Dom i fin n <$> instantiate' tac <*> instantiate' x@@ -197,18 +219,19 @@   instantiate' (ElimCmp cmp fs t v as bs) =     ElimCmp cmp fs <$> instantiate' t <*> instantiate' v <*> instantiate' as <*> instantiate' bs   instantiate' (LevelCmp cmp u v)   = uncurry (LevelCmp cmp) <$> instantiate' (u,v)-  instantiate' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp)  <$> instantiate' (tela,telb)   instantiate' (SortCmp cmp a b)    = uncurry (SortCmp cmp) <$> instantiate' (a,b)-  instantiate' (Guarded c pid)      = Guarded <$> instantiate' c <*> pure pid   instantiate' (UnBlock m)          = return $ UnBlock m-  instantiate' (FindInstance m b args) = FindInstance m b <$> mapM instantiate' args+  instantiate' (FindInstance m cs)  = FindInstance m <$> mapM instantiate' cs   instantiate' (IsEmpty r t)        = IsEmpty r <$> instantiate' t   instantiate' (CheckSizeLtSat t)   = CheckSizeLtSat <$> instantiate' t   instantiate' c@CheckFunDef{}      = return c   instantiate' (HasBiggerSort a)    = HasBiggerSort <$> instantiate' a   instantiate' (HasPTSRule a b)     = uncurry HasPTSRule <$> instantiate' (a,b)-  instantiate' (UnquoteTactic m t h g) = UnquoteTactic m <$> instantiate' t <*> instantiate' h <*> instantiate' g+  instantiate' (CheckLockedVars a b c d) =+    CheckLockedVars <$> instantiate' a <*> instantiate' b <*> instantiate' c <*> instantiate' d+  instantiate' (UnquoteTactic t h g) = UnquoteTactic <$> instantiate' t <*> instantiate' h <*> instantiate' g   instantiate' c@CheckMetaInst{}    = return c+  instantiate' (UsableAtModality mod t) = UsableAtModality mod <$> instantiate' t  instance Instantiate CompareAs where   instantiate' (AsTermsOf a) = AsTermsOf <$> instantiate' a@@ -216,11 +239,13 @@   instantiate' AsTypes       = return AsTypes  instance Instantiate Candidate where-  instantiate' (Candidate u t ov) = Candidate <$> instantiate' u <*> instantiate' t <*> pure ov+  instantiate' (Candidate q u t ov) = Candidate q <$> instantiate' u <*> instantiate' t <*> pure ov  instance Instantiate EqualityView where   instantiate' (OtherType t)            = OtherType     <$> instantiate' t+  instantiate' (IdiomType t)            = IdiomType+    <$> instantiate' t   instantiate' (EqualityType s eq l t a b) = EqualityType     <$> instantiate' s     <*> return eq@@ -233,52 +258,72 @@ -- * Reduction to weak head normal form. --------------------------------------------------------------------------- +-- | Is something (an elimination of) a meta variable?+--   Does not perform any reductions.+ class IsMeta a where-  isMeta :: HasBuiltins m => a -> m (Maybe MetaId)+  isMeta :: a -> Maybe MetaId  instance IsMeta Term where-  isMeta (MetaV m _) = return $ Just m-  isMeta _           = return Nothing+  isMeta (MetaV m _) = Just m+  isMeta _           = Nothing -instance IsMeta Type where+instance IsMeta a => IsMeta (Sort' a) where+  isMeta (MetaS m _) = Just m+  isMeta _           = Nothing++instance IsMeta a => IsMeta (Type'' t a) where   isMeta = isMeta . unEl -instance IsMeta Level where-  isMeta = isMeta <=< reallyUnLevelView+instance IsMeta a => IsMeta (Elim' a) where+  isMeta Proj{}    = Nothing+  isMeta IApply{}  = Nothing+  isMeta (Apply a) = isMeta a -instance IsMeta Sort where-  isMeta (MetaS m _) = return $ Just m-  isMeta _           = return Nothing+instance IsMeta a => IsMeta (Arg a) where+  isMeta = isMeta . unArg +instance IsMeta a => IsMeta (Level' a) where+  isMeta (Max 0 [l]) = isMeta l+  isMeta _           = Nothing++instance IsMeta a => IsMeta (PlusLevel' a) where+  isMeta (Plus 0 l)  = isMeta l+  isMeta _           = Nothing+ instance IsMeta CompareAs where   isMeta (AsTermsOf a) = isMeta a-  isMeta AsSizes       = return Nothing-  isMeta AsTypes       = return Nothing+  isMeta AsSizes       = Nothing+  isMeta AsTypes       = Nothing  -- | 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-  :: (Reduce t, IsMeta t, MonadReduce m, HasBuiltins m)-  => t -> (MetaId -> t -> m a) -> (NotBlocked -> t -> m a) -> m a+  :: (Reduce t, IsMeta t, MonadReduce m)+  => t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a ifBlocked t blocked unblocked = do   t <- reduceB t   case t of-    Blocked m t -> blocked m t-    NotBlocked nb t -> isMeta t >>= \case-      Just m    -> blocked m t+    Blocked m t     -> blocked m t+    NotBlocked nb t -> case isMeta t of -- #4899: MetaS counts as NotBlocked at the moment+      Just m    -> blocked (unblockOnMeta m) t       Nothing   -> unblocked nb t +-- | Throw pattern violation if blocked or a meta.+abortIfBlocked :: (MonadReduce m, MonadBlock m, IsMeta t, Reduce t) => t -> m t+abortIfBlocked t = ifBlocked t (const . patternViolation) (const return)+ isBlocked-  :: (Reduce t, IsMeta t, MonadReduce m, HasBuiltins m)-  => t -> m (Maybe MetaId)+  :: (Reduce t, IsMeta t, MonadReduce m)+  => t -> m (Maybe Blocker) isBlocked t = ifBlocked t (\m _ -> return $ Just m) (\_ _ -> return Nothing)  class Reduce t where-    reduce'  :: t -> ReduceM t-    reduceB' :: t -> ReduceM (Blocked t)+  reduce'  :: t -> ReduceM t+  reduceB' :: t -> ReduceM (Blocked t) -    reduce'  t = ignoreBlocking <$> reduceB' t-    reduceB' t = notBlocked <$> reduce' t+  reduce'  t = ignoreBlocking <$> reduceB' t+  reduceB' t = notBlocked <$> reduce' t  instance Reduce Type where     reduce'  (El s t) = workOnTypes $ El s <$> reduce' t@@ -288,21 +333,21 @@     reduce' s = do       s <- instantiate' s       case s of-        PiSort a s2 -> do-          (s1' , s2') <- reduce' (getSort a , s2)-          let a' = set lensSort s1' a-          maybe (return $ PiSort a' s2') reduce' $ piSort' a' s2'+        PiSort a s1 s2 -> do+          (s1' , s2') <- reduce' (s1 , s2)+          maybe (return $ PiSort a s1' s2') reduce' $ piSort' a s1' s2'         FunSort s1 s2 -> do           (s1' , s2') <- reduce (s1 , s2)           maybe (return $ FunSort s1' s2') reduce' $ funSort' s1' s2'         UnivSort s' -> do           s' <- reduce' s'-          ui <- univInf-          caseMaybe (univSort' ui s') (return $ UnivSort s') reduce'+          caseMaybe (univSort' s') (return $ UnivSort s') reduce'         Prop s'    -> Prop <$> reduce' s'         Type s'    -> Type <$> reduce' s'-        Inf        -> return Inf+        Inf f n    -> return $ Inf f n+        SSet s'    -> SSet <$> reduce' s'         SizeUniv   -> return SizeUniv+        LockUniv   -> return LockUniv         MetaS x es -> return s         DefS d es  -> return s -- postulated sorts do not reduce         DummyS{}   -> return s@@ -314,29 +359,12 @@  instance Reduce Level where   reduce'  (Max m as) = levelMax m <$> mapM reduce' as-  reduceB' (Max m as) = fmap (levelMax m) . traverse id <$> traverse reduceB' as+  reduceB' (Max m as) = fmap (levelMax m) . blockAny <$> traverse reduceB' as  instance Reduce PlusLevel where   reduceB' (Plus n l) = fmap (Plus n) <$> reduceB' l -instance Reduce LevelAtom where-  reduceB' l = case l of-    MetaLevel m vs   -> fromTm (MetaV m vs)-    NeutralLevel r v -> return $ NotBlocked r $ NeutralLevel r v-    BlockedLevel m v ->-      ifM (isInstantiatedMeta m) (fromTm v) (return $ Blocked m $ BlockedLevel m v)-    UnreducedLevel v -> fromTm v-    where-      fromTm v = do-        bv <- reduceB' v-        let v = ignoreBlocking bv-        case bv of-          NotBlocked r (MetaV m vs) -> return $ NotBlocked r $ MetaLevel m vs-          Blocked m _               -> return $ Blocked m    $ BlockedLevel m v-          NotBlocked r _            -> return $ NotBlocked r $ NeutralLevel r v---instance (Subst t a, Reduce a) => Reduce (Abs a) where+instance (Subst a, Reduce a) => Reduce (Abs a) where   reduce' b@(Abs x _) = Abs x <$> underAbstraction_ b reduce'   reduce' (NoAbs x v) = NoAbs x <$> reduce' v @@ -378,25 +406,16 @@ reduceIApply :: ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term) reduceIApply = reduceIApply' reduceB' -blockedOrMeta :: Blocked Term -> Blocked ()-blockedOrMeta r =-  case r of-    Blocked m _              -> Blocked m ()-    NotBlocked _ (MetaV m _) -> Blocked m ()-    NotBlocked i _           -> NotBlocked i ()- reduceIApply' :: (Term -> ReduceM (Blocked Term)) -> ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term) reduceIApply' red d (IApply x y r : es) = do   view <- intervalView'   r <- reduceB' r   -- We need to propagate the blocking information so that e.g.   -- we postpone "someNeutralPath ?0 = a" rather than fail.-  let blockedInfo = blockedOrMeta r-   case view (ignoreBlocking r) of    IZero -> red (applyE x es)    IOne  -> red (applyE y es)-   _     -> fmap (<* blockedInfo) (reduceIApply' red d es)+   _     -> fmap (<* r) (reduceIApply' red d es) reduceIApply' red d (_ : es) = reduceIApply' red d es reduceIApply' _   d [] = d @@ -424,7 +443,7 @@   if not tryFast then slowReduceTerm v                  else     case v of-      MetaV x _ -> ifM (isOpen x) (return $ notBlocked v) (maybeFast v)+      MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)       _         -> maybeFast v   where     isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x@@ -433,7 +452,8 @@ slowReduceTerm :: Term -> ReduceM (Blocked Term) slowReduceTerm v = do     v <- instantiate' v-    let done = return $ notBlocked v+    let done | MetaV x _ <- v = return $ blocked x v+             | otherwise      = return $ notBlocked v         iapp = reduceIApply done     case v of --    Andreas, 2012-11-05 not reducing meta args does not destroy anything@@ -463,7 +483,7 @@       reduceNat v@(Con c ci []) = do         mz  <- getBuiltin' builtinZero         case v of-          _ | Just v == mz  -> return $ Lit $ LitNat (getRange c) 0+          _ | Just v == mz  -> return $ Lit $ LitNat 0           _                 -> return v       reduceNat v@(Con c ci [Apply a]) | visible a && isRelevant a = do         ms  <- getBuiltin' builtinSuc@@ -471,9 +491,9 @@           _ | Just (Con c ci []) == ms -> inc <$> reduce' (unArg a)           _                         -> return v           where-            inc w = case w of-              Lit (LitNat r n) -> Lit (LitNat (fuseRange c r) $ n + 1)-              _                -> Con c ci [Apply $ defaultArg w]+            inc = \case+              Lit (LitNat n) -> Lit $ LitNat $ n + 1+              w              -> Con c ci [Apply $ defaultArg w]       reduceNat v = return v  -- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion@@ -522,11 +542,12 @@ unfoldDefinitionStep :: Bool -> Term -> QName -> Elims -> ReduceM (Reduced (Blocked Term) Term) unfoldDefinitionStep unfoldDelayed v0 f es =   {-# SCC "reduceDef" #-} do-  traceSDoc "tc.reduce" 90 ("unfoldDefinitionStep v0" <+> prettyTCM v0) $ do+  traceSDoc "tc.reduce" 90 ("unfoldDefinitionStep v0" <+> pretty v0) $ do   info <- getConstInfo f   rewr <- instantiateRewriteRules =<< getRewriteRulesFor f   allowed <- asksTC envAllowedReductions-  prp <- isPropM $ defType info+  prp <- runBlocked $ isPropM $ defType info+  defOk <- shouldReduceDef f   let def = theDef info       v   = v0 `applyE` es       -- Non-terminating functions@@ -537,17 +558,20 @@         (defNonterminating info && SmallSet.notMember NonTerminatingReductions allowed)         || (defTerminationUnconfirmed info && SmallSet.notMember UnconfirmedReductions allowed)         || (defDelayed info == Delayed && not unfoldDelayed)-        || prp || isIrrelevant (defArgInfo info)+        || prp == Right True || isIrrelevant (defArgInfo info)+        || not defOk       copatterns = defCopatternLHS info   case def of-    Constructor{conSrcCon = c} ->-      noReduction $ notBlocked $ Con (c `withRangeOf` f) ConOSystem [] `applyE` es+    Constructor{conSrcCon = c} -> do+      let hd = Con (c `withRangeOf` f) ConOSystem+      rewrite (NotBlocked ReallyNotBlocked ()) hd rewr es     Primitive{primAbstr = ConcreteDef, primName = x, primClauses = cls} -> do       pf <- fromMaybe __IMPOSSIBLE__ <$> getPrimitive' x       if FunctionReductions `SmallSet.member` allowed         then reducePrimitive x v0 f es pf dontUnfold                              cls (defCompiled info) rewr         else noReduction $ notBlocked v+    PrimitiveSort{ primSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es     _  -> do       if (RecursiveReductions `SmallSet.member` allowed) ||          (isJust (isProjection_ def) && ProjectionReductions `SmallSet.member` allowed) || -- includes projection-like@@ -574,20 +598,20 @@               let es1' = map (fmap Apply) args1'               if null cls && null rewr then do                 noReduction $ applyE (Def f []) <$> do-                  traverse id $-                    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             YesReduction simpl v -> yesReduction simpl $ v `applyE` es2       where           ar  = primFunArity pf-          mredToBlocked :: MaybeReduced a -> Blocked a-          mredToBlocked (MaybeRed NotReduced  x) = notBlocked x-          mredToBlocked (MaybeRed (Reduced b) x) = x <$ b +          mredToBlocked :: IsMeta t => 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-      traceSDoc "tc.reduce" 90 ("reduceNormalE v0 =" <+> prettyTCM v0) $ 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@@ -606,41 +630,59 @@         case ev of           NoReduction v -> do             reportSDoc "tc.reduce" 90 $ vcat-              [ "*** tried to reduce " <+> prettyTCM f-              , "    es =  " <+> sep (map (prettyTCM . ignoreReduced) es)-              -- , "*** tried to reduce " <+> prettyTCM vfull-              , "    stuck on" <+> prettyTCM (ignoreBlocking v)+              [ "*** tried to reduce " <+> pretty f+              , "    es =  " <+> sep (map (pretty . ignoreReduced) es)+              -- , "*** tried to reduce " <+> pretty vfull+              , "    stuck on" <+> pretty (ignoreBlocking v)               ]           YesReduction _simpl v -> do-            reportSDoc "tc.reduce"  90 $ "*** reduced definition: " <+> prettyTCM f-            reportSDoc "tc.reduce"  95 $ "    result" <+> prettyTCM v-            reportSDoc "tc.reduce" 100 $ "    raw   " <+> text (show v)+            reportSDoc "tc.reduce"  90 $ "*** reduced definition: " <+> pretty f+            reportSDoc "tc.reduce"  95 $ "    result" <+> pretty v +-- | Specialized version to put in boot file.+reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)+reduceDefCopyTCM = reduceDefCopy+ -- | Reduce a non-primitive definition if it is a copy linking to another def.-reduceDefCopy :: forall m. (MonadReduce m, HasConstInfo m, HasOptions m,-                            ReadTCState m, MonadTCEnv m, MonadDebug m)-              => QName -> Elims -> m (Reduced () Term)+reduceDefCopy :: forall m. PureTCM m => QName -> Elims -> m (Reduced () Term) reduceDefCopy f es = do   info <- getConstInfo f-  rewr <- instantiateRewriteRules =<< getRewriteRulesFor f-  if (defCopy info) then reduceDef_ info rewr f es else return $ NoReduction ()+  case theDef info of+    _ | not $ defCopy info     -> return $ NoReduction ()+    Constructor{conSrcCon = c} -> return $ YesReduction YesSimplification (Con c ConOSystem es)+    _                          -> reduceDef_ info f es   where-    reduceDef_ :: Definition -> RewriteRules -> QName -> Elims -> m (Reduced () Term)-    reduceDef_ info rewr f es = do-      let v0   = Def f []-          cls  = (defClauses info)-          mcc  = (defCompiled info)-      if (defDelayed info == Delayed) || (defNonterminating info)-       then return $ NoReduction ()-       else do-          ev <- liftReduce $ appDefE_ f v0 cls mcc rewr $ map notReduced es-          case ev of-            YesReduction simpl t -> return $ YesReduction simpl t-            NoReduction{}        -> return $ NoReduction ()+    reduceDef_ :: Definition -> QName -> Elims -> m (Reduced () Term)+    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+            ps    = namedClausePats cl+            nargs = length es+            -- appDefE_ cannot handle underapplied functions, so we eta-expand here if that's the+            -- case. We use this function to compute display forms from module applications and in+            -- that case we don't always have saturated applications.+            (lam, es') = (unlamView xs, newes)+              where+                etaArgs [] _ = []+                etaArgs (p : ps) []+                  | VarP _ x <- namedArg p = Arg (getArgInfo p) (dbPatVarName x) : etaArgs ps []+                  | otherwise              = []+                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 ]+        if (defDelayed info == Delayed) || (defNonterminating info)+         then return $ NoReduction ()+         else do+            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__  -- | Reduce simple (single clause) definitions.-reduceHead :: (HasBuiltins m, HasConstInfo m, MonadReduce m, MonadDebug m)-           => Term -> m (Blocked Term)+reduceHead :: PureTCM m => Term -> m (Blocked Term) reduceHead v = do -- ignoreAbstractMode $ do   -- Andreas, 2013-02-18 ignoreAbstractMode leads to information leakage   -- see Issue 796@@ -654,7 +696,7 @@       abstractMode <- envAbstractMode <$> askTC       isAbstract <- treatAbstractly f       traceSLn "tc.inj.reduce" 50 (-        "reduceHead: we are in " ++ show abstractMode++ "; " ++ show f +++        "reduceHead: we are in " ++ show abstractMode++ "; " ++ prettyShow f ++         " is treated " ++ if isAbstract then "abstractly" else "concretely"         ) $ do       let v0  = Def f []@@ -667,7 +709,7 @@         -- type checker loop here on non-terminating functions.         -- see test/fail/TerminationInfiniteRecord         Function{ funClauses = [ _ ], funDelayed = NotDelayed, funTerminates = Just True } -> do-          traceSLn "tc.inj.reduce" 50 ("reduceHead: head " ++ show 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@@ -675,7 +717,7 @@     _ -> return $ notBlocked v  -- | Unfold a single inlined function.-unfoldInlined :: (HasConstInfo m, MonadReduce m) => Term -> m Term+unfoldInlined :: PureTCM m => Term -> m Term unfoldInlined v = do   inTypes <- viewTC eWorkingOnTypes   case v of@@ -710,18 +752,18 @@  appDefE :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) appDefE v cc rewr es = do-  traceSDoc "tc.reduce" 90 ("appDefE v = " <+> prettyTCM v) $ do+  traceSDoc "tc.reduce" 90 ("appDefE v = " <+> pretty v) $ do   r <- matchCompiledE cc es   case r of     YesReduction simpl t -> return $ YesReduction simpl t-    NoReduction es'      -> rewrite (void es') v rewr (ignoreBlocking es')+    NoReduction es'      -> rewrite (void es') (applyE v) rewr (ignoreBlocking es')  -- | Apply a defined function to it's arguments, using the original clauses. appDef' :: Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term) appDef' v cls rewr args = appDefE' v cls rewr $ map (fmap Apply) args  appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)-appDefE' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> prettyTCM v) $ do+appDefE' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do   goCls cls $ map ignoreReduced es   where     goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term)@@ -733,7 +775,7 @@         -- the remaining clauses (see Issue 907).         -- Andrea(s), 2014-12-05:  We return 'MissingClauses' here, since this         -- is the most conservative reason.-        [] -> rewrite (NotBlocked MissingClauses ()) v rewr es+        [] -> rewrite (NotBlocked MissingClauses ()) (applyE v) rewr es         cl : cls -> do           let pats = namedClausePats cl               body = clauseBody cl@@ -743,18 +785,18 @@           if length es < npats then goCls cls es else do             let (es0, es1) = splitAt npats es             (m, es0) <- matchCopatterns pats es0-            es <- return $ es0 ++ es1+            let es = es0 ++ es1             case m of               No         -> goCls cls es-              DontKnow b -> rewrite b v rewr es+              DontKnow b -> rewrite b (applyE v) rewr es               Yes simpl vs -- vs is the subst. for the variables bound in body                 | 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+                    let sigma = buildSubstitution impossible nvars vs                     return $ YesReduction simpl $ applySubst sigma w `applyE` es1-                | otherwise     -> rewrite (NotBlocked AbsurdMatch ()) v rewr es+                | otherwise     -> rewrite (NotBlocked AbsurdMatch ()) (applyE v) rewr es  instance Reduce a => Reduce (Closure a) where     reduce' cl = do@@ -775,18 +817,19 @@   reduce' (ElimCmp cmp fs t v as bs) =     ElimCmp cmp fs <$> reduce' t <*> reduce' v <*> reduce' as <*> reduce' bs   reduce' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> reduce' (u,v)-  reduce' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp)  <$> reduce' (tela,telb)   reduce' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> reduce' (a,b)-  reduce' (Guarded c pid)       = Guarded <$> reduce' c <*> pure pid   reduce' (UnBlock m)           = return $ UnBlock m-  reduce' (FindInstance m b cands) = FindInstance m b <$> mapM reduce' cands+  reduce' (FindInstance m cs)   = FindInstance m <$> mapM reduce' cs   reduce' (IsEmpty r t)         = IsEmpty r <$> reduce' t   reduce' (CheckSizeLtSat t)    = CheckSizeLtSat <$> reduce' t   reduce' c@CheckFunDef{}       = return c   reduce' (HasBiggerSort a)     = HasBiggerSort <$> reduce' a   reduce' (HasPTSRule a b)      = uncurry HasPTSRule <$> reduce' (a,b)-  reduce' (UnquoteTactic m t h g) = UnquoteTactic m <$> reduce' t <*> reduce' h <*> reduce' g+  reduce' (UnquoteTactic t h g) = UnquoteTactic <$> reduce' t <*> reduce' h <*> reduce' g+  reduce' (CheckLockedVars a b c d) =+    CheckLockedVars <$> reduce' a <*> reduce' b <*> reduce' c <*> reduce' d   reduce' c@CheckMetaInst{}     = return c+  reduce' (UsableAtModality mod t) = UsableAtModality mod <$> reduce' t  instance Reduce CompareAs where   reduce' (AsTermsOf a) = AsTermsOf <$> reduce' a@@ -794,14 +837,16 @@   reduce' AsTypes       = return AsTypes  instance Reduce e => Reduce (Map k e) where-    reduce' = traverse reduce'+  reduce' = traverse reduce'  instance Reduce Candidate where-  reduce' (Candidate u t ov) = Candidate <$> reduce' u <*> reduce' t <*> pure ov+  reduce' (Candidate q u t ov) = Candidate q <$> reduce' u <*> reduce' t <*> pure ov  instance Reduce EqualityView where   reduce' (OtherType t)            = OtherType     <$> reduce' t+  reduce' (IdiomType t)            = IdiomType+    <$> reduce' t   reduce' (EqualityType s eq l t a b) = EqualityType     <$> reduce' s     <*> return eq@@ -820,6 +865,8 @@  -- | Only unfold definitions if this leads to simplification --   which means that a constructor/literal pattern is matched.+--   We include reduction of IApply patterns, as `p i0` is akin to+--   matcing on the `i0` constructor of interval. class Simplify t where   simplify' :: t -> ReduceM t @@ -854,23 +901,24 @@ instance Simplify Term where   simplify' v = do     v <- instantiate' v+    let iapp es m = ignoreBlocking <$> reduceIApply' (fmap notBlocked . simplify') (notBlocked <$> m) es     case v of-      Def f vs   -> do+      Def f vs   -> iapp vs $ do         let keepGoing simp v = return (simp, notBlocked v)         (simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs         traceSDoc "tc.simplify'" 90 (           text ("simplify': unfolding definition returns " ++ show simpl)-            <+> prettyTCM (ignoreBlocking v)) $ do+            <+> pretty (ignoreBlocking v)) $ do         case simpl of           YesSimplification -> simplifyBlocked' v -- Dangerous, but if @simpl@ then @v /= Def f vs@           NoSimplification  -> Def f <$> simplify' vs-      MetaV x vs -> MetaV x  <$> simplify' vs-      Con c ci vs-> Con c ci <$> simplify' vs+      MetaV x vs -> iapp vs $ MetaV x  <$> simplify' vs+      Con c ci vs-> iapp vs $ Con c ci <$> simplify' vs       Sort s     -> Sort     <$> simplify' s       Level l    -> levelTm  <$> simplify' l       Pi a b     -> Pi       <$> simplify' a <*> simplify' b       Lit l      -> return v-      Var i vs   -> Var i    <$> simplify' vs+      Var i vs   -> iapp vs $ Var i    <$> simplify' vs       Lam h v    -> Lam h    <$> simplify' v       DontCare v -> dontCare <$> simplify' v       Dummy{}    -> return v@@ -885,15 +933,15 @@ instance Simplify Sort where     simplify' s = do       case s of-        PiSort a s -> piSort <$> simplify' a <*> simplify' s+        PiSort a s1 s2 -> piSort <$> simplify' a <*> simplify' s1 <*> simplify' s2         FunSort s1 s2 -> funSort <$> simplify' s1 <*> simplify' s2-        UnivSort s -> do-          ui <- univInf-          univSort ui <$> simplify' s+        UnivSort s -> univSort <$> simplify' s         Type s     -> Type <$> simplify' s         Prop s     -> Prop <$> simplify' s-        Inf        -> return s+        Inf _ _    -> return s+        SSet s     -> SSet <$> simplify' s         SizeUniv   -> return s+        LockUniv   -> return s         MetaS x es -> MetaS x <$> simplify' es         DefS d es  -> DefS d <$> simplify' es         DummyS{}   -> return s@@ -904,16 +952,7 @@ instance Simplify PlusLevel where   simplify' (Plus n l) = Plus n <$> simplify' l -instance Simplify LevelAtom where-  simplify' l = do-    l <- instantiate' l-    case l of-      MetaLevel m vs   -> MetaLevel m <$> simplify' vs-      BlockedLevel m v -> BlockedLevel m <$> simplify' v-      NeutralLevel r v -> NeutralLevel r <$> simplify' v -- ??-      UnreducedLevel v -> UnreducedLevel <$> simplify' v -- ??--instance (Subst t a, Simplify a) => Simplify (Abs a) where+instance (Subst a, Simplify a) => Simplify (Abs a) where     simplify' a@(Abs x _) = Abs x <$> underAbstraction_ a simplify'     simplify' (NoAbs x v) = NoAbs x <$> simplify' v @@ -925,12 +964,12 @@         x <- enterClosure cl simplify'         return $ cl { clValue = x } -instance (Subst t a, Simplify a) => Simplify (Tele a) where+instance (Subst a, Simplify a) => Simplify (Tele a) where   simplify' EmptyTel        = return EmptyTel   simplify' (ExtendTel a b) = uncurry ExtendTel <$> simplify' (a, b)  instance Simplify ProblemConstraint where-  simplify' (PConstr pid c) = PConstr pid <$> simplify' c+  simplify' (PConstr pid unblock c) = PConstr pid unblock <$> simplify' c  instance Simplify Constraint where   simplify' (ValueCmp cmp t u v) = do@@ -942,18 +981,19 @@   simplify' (ElimCmp cmp fs t v as bs) =     ElimCmp cmp fs <$> simplify' t <*> simplify' v <*> simplify' as <*> simplify' bs   simplify' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> simplify' (u,v)-  simplify' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp) <$> simplify' (tela,telb)   simplify' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> simplify' (a,b)-  simplify' (Guarded c pid)       = Guarded <$> simplify' c <*> pure pid   simplify' (UnBlock m)           = return $ UnBlock m-  simplify' (FindInstance m b cands) = FindInstance m b <$> mapM simplify' cands+  simplify' (FindInstance m cs)   = FindInstance m <$> mapM simplify' cs   simplify' (IsEmpty r t)         = IsEmpty r <$> simplify' t   simplify' (CheckSizeLtSat t)    = CheckSizeLtSat <$> simplify' t   simplify' c@CheckFunDef{}       = return c   simplify' (HasBiggerSort a)     = HasBiggerSort <$> simplify' a   simplify' (HasPTSRule a b)      = uncurry HasPTSRule <$> simplify' (a,b)-  simplify' (UnquoteTactic m t h g) = UnquoteTactic m <$> simplify' t <*> simplify' h <*> simplify' g+  simplify' (UnquoteTactic t h g) = UnquoteTactic <$> simplify' t <*> simplify' h <*> simplify' g+  simplify' (CheckLockedVars a b c d) =+    CheckLockedVars <$> simplify' a <*> simplify' b <*> simplify' c <*> simplify' d   simplify' c@CheckMetaInst{}     = return c+  simplify' (UsableAtModality mod t) = UsableAtModality mod <$> simplify' t  instance Simplify CompareAs where   simplify' (AsTermsOf a) = AsTermsOf <$> simplify' a@@ -977,11 +1017,13 @@   simplify' (Display n ps v) = Display n <$> simplify' ps <*> return v  instance Simplify Candidate where-  simplify' (Candidate u t ov) = Candidate <$> simplify' u <*> simplify' t <*> pure ov+  simplify' (Candidate q u t ov) = Candidate q <$> simplify' u <*> simplify' t <*> pure ov  instance Simplify EqualityView where   simplify' (OtherType t)            = OtherType     <$> simplify' t+  simplify' (IdiomType t)            = IdiomType+    <$> simplify' t   simplify' (EqualityType s eq l t a b) = EqualityType     <$> simplify' s     <*> return eq@@ -1039,15 +1081,15 @@     normalise' s = do       s <- reduce' s       case s of-        PiSort a s -> piSort <$> normalise' a <*> normalise' s+        PiSort a s1 s2 -> piSort <$> normalise' a <*> normalise' s1 <*> normalise' s2         FunSort s1 s2 -> funSort <$> normalise' s1 <*> normalise' s2-        UnivSort s -> do-          ui <- univInf-          univSort ui <$> normalise' s+        UnivSort s -> univSort <$> normalise' s         Prop s     -> Prop <$> normalise' s         Type s     -> Type <$> normalise' s-        Inf        -> return Inf+        Inf _ _    -> return s+        SSet s     -> SSet <$> normalise' s         SizeUniv   -> return SizeUniv+        LockUniv   -> return LockUniv         MetaS x es -> return s         DefS d es  -> return s         DummyS{}   -> return s@@ -1059,18 +1101,18 @@     normalise' v = ifM shouldTryFastReduce (fastNormalise v) (slowNormaliseArgs =<< reduce' v)  slowNormaliseArgs :: Term -> ReduceM Term-slowNormaliseArgs v = case v of+slowNormaliseArgs = \case   Var n vs    -> Var n      <$> normalise' vs   Con c ci vs -> Con c ci   <$> normalise' vs   Def f vs    -> Def f      <$> normalise' vs   MetaV x vs  -> MetaV x    <$> normalise' vs-  Lit _       -> return v+  v@(Lit _)   -> return v   Level l     -> levelTm    <$> normalise' l   Lam h b     -> Lam h      <$> normalise' b   Sort s      -> Sort       <$> normalise' s   Pi a b      -> uncurry Pi <$> normalise' (a, b)-  DontCare _  -> return v-  Dummy{}     -> return v+  v@DontCare{}-> return v+  v@Dummy{}   -> return v  -- Note: not the default instance for Elim' since we do something special for Arg. instance Normalise t => Normalise (Elim' t) where@@ -1084,16 +1126,7 @@ instance Normalise PlusLevel where   normalise' (Plus n l) = Plus n <$> normalise' l -instance Normalise LevelAtom where-  normalise' l = do-    l <- reduce' l-    case l of-      MetaLevel m vs   -> MetaLevel m <$> normalise' vs-      BlockedLevel m v -> BlockedLevel m <$> normalise' v-      NeutralLevel r v -> NeutralLevel r <$> normalise' v-      UnreducedLevel{} -> __IMPOSSIBLE__    -- I hope--instance (Subst t a, Normalise a) => Normalise (Abs a) where+instance (Subst a, Normalise a) => Normalise (Abs a) where     normalise' a@(Abs x _) = Abs x <$> underAbstraction_ a normalise'     normalise' (NoAbs x v) = NoAbs x <$> normalise' v @@ -1110,12 +1143,12 @@         x <- enterClosure cl normalise'         return $ cl { clValue = x } -instance (Subst t a, Normalise a) => Normalise (Tele a) where+instance (Subst a, Normalise a) => Normalise (Tele a) where   normalise' EmptyTel        = return EmptyTel   normalise' (ExtendTel a b) = uncurry ExtendTel <$> normalise' (a, b)  instance Normalise ProblemConstraint where-  normalise' (PConstr pid c) = PConstr pid <$> normalise' c+  normalise' (PConstr pid unblock c) = PConstr pid unblock <$> normalise' c  instance Normalise Constraint where   normalise' (ValueCmp cmp t u v) = do@@ -1127,18 +1160,19 @@   normalise' (ElimCmp cmp fs t v as bs) =     ElimCmp cmp fs <$> normalise' t <*> normalise' v <*> normalise' as <*> normalise' bs   normalise' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> normalise' (u,v)-  normalise' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp) <$> normalise' (tela,telb)   normalise' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> normalise' (a,b)-  normalise' (Guarded c pid)       = Guarded <$> normalise' c <*> pure pid   normalise' (UnBlock m)           = return $ UnBlock m-  normalise' (FindInstance m b cands) = FindInstance m b <$> mapM normalise' cands+  normalise' (FindInstance m cs)   = FindInstance m <$> mapM normalise' cs   normalise' (IsEmpty r t)         = IsEmpty r <$> normalise' t   normalise' (CheckSizeLtSat t)    = CheckSizeLtSat <$> normalise' t   normalise' c@CheckFunDef{}       = return c   normalise' (HasBiggerSort a)     = HasBiggerSort <$> normalise' a   normalise' (HasPTSRule a b)      = uncurry HasPTSRule <$> normalise' (a,b)-  normalise' (UnquoteTactic m t h g) = UnquoteTactic m <$> normalise' t <*> normalise' h <*> normalise' g+  normalise' (UnquoteTactic t h g) = UnquoteTactic <$> normalise' t <*> normalise' h <*> normalise' g+  normalise' (CheckLockedVars a b c d) =+    CheckLockedVars <$> normalise' a <*> normalise' b <*> normalise' c <*> normalise' d   normalise' c@CheckMetaInst{}     = return c+  normalise' (UsableAtModality mod t) = UsableAtModality mod <$> normalise' t  instance Normalise CompareAs where   normalise' (AsTermsOf a) = AsTermsOf <$> normalise' a@@ -1162,11 +1196,13 @@   normalise' (Display n ps v) = Display n <$> normalise' ps <*> return v  instance Normalise Candidate where-  normalise' (Candidate u t ov) = Candidate <$> normalise' u <*> normalise' t <*> pure ov+  normalise' (Candidate q u t ov) = Candidate q <$> normalise' u <*> normalise' t <*> pure ov  instance Normalise EqualityView where   normalise' (OtherType t)            = OtherType     <$> normalise' t+  normalise' (IdiomType t)            = IdiomType+    <$> normalise' t   normalise' (EqualityType s eq l t a b) = EqualityType     <$> normalise' s     <*> return eq@@ -1200,6 +1236,7 @@ instance InstantiateFull t => InstantiateFull (Named name t) instance InstantiateFull t => InstantiateFull (Open t) instance InstantiateFull t => InstantiateFull (WithArity t)+instance InstantiateFull t => InstantiateFull (IPBoundary' t)  -- Tuples: @@ -1253,13 +1290,13 @@         case s of             Type n     -> Type <$> instantiateFull' n             Prop n     -> Prop <$> instantiateFull' n-            PiSort a s -> piSort <$> instantiateFull' a <*> instantiateFull' s+            SSet n     -> SSet <$> instantiateFull' n+            PiSort a s1 s2 -> piSort <$> instantiateFull' a <*> instantiateFull' s1 <*> instantiateFull' s2             FunSort s1 s2 -> funSort <$> instantiateFull' s1 <*> instantiateFull' s2-            UnivSort s -> do-              ui <- univInf-              univSort ui <$> instantiateFull' s-            Inf        -> return s+            UnivSort s -> univSort <$> instantiateFull' s+            Inf _ _    -> return s             SizeUniv   -> return s+            LockUniv   -> return s             MetaS x es -> MetaS x <$> instantiateFull' es             DefS d es  -> DefS d <$> instantiateFull' es             DummyS{}   -> return s@@ -1269,21 +1306,22 @@       El <$> instantiateFull' s <*> instantiateFull' t  instance InstantiateFull Term where-    instantiateFull' v = etaOnce =<< do -- Andreas, 2010-11-12 DONT ETA!? eta-reduction breaks subject reduction--- but removing etaOnce now breaks everything-      v <- instantiate' v-      case v of+    instantiateFull' = instantiate' >=> recurse >=> etaOnce+      -- Andreas, 2010-11-12 DONT ETA!? eta-reduction breaks subject reduction+      -- 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-          Lit _       -> return v+          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-          Dummy{}     -> return v+          v@Dummy{}   -> return v  instance InstantiateFull Level where   instantiateFull' (Max m as) = levelMax m <$> instantiateFull' as@@ -1291,20 +1329,6 @@ instance InstantiateFull PlusLevel where   instantiateFull' (Plus n l) = Plus n <$> instantiateFull' l -instance InstantiateFull LevelAtom where-  instantiateFull' l = case l of-    MetaLevel m vs -> do-      v <- instantiateFull' (MetaV m vs)-      case v of-        MetaV m vs -> return $ MetaLevel m vs-        _          -> return $ UnreducedLevel v-    NeutralLevel r v -> NeutralLevel r <$> instantiateFull' v-    BlockedLevel m v ->-      ifM (isInstantiatedMeta m)-          (UnreducedLevel <$> instantiateFull' v)-          (BlockedLevel m <$> instantiateFull' v)-    UnreducedLevel v -> UnreducedLevel <$> instantiateFull' v- instance InstantiateFull Substitution where   instantiateFull' sigma =     case sigma of@@ -1328,7 +1352,7 @@     instantiateFull' p@ProjP{}      = return p     instantiateFull' (IApplyP o t u x) = IApplyP o <$> instantiateFull' t <*> instantiateFull' u <*> instantiateFull' x -instance (Subst t a, InstantiateFull a) => InstantiateFull (Abs a) where+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 @@ -1341,10 +1365,10 @@         return $ cl { clValue = x }  instance InstantiateFull ProblemConstraint where-  instantiateFull' (PConstr p c) = PConstr p <$> instantiateFull' c+  instantiateFull' (PConstr p u c) = PConstr p u <$> instantiateFull' c  instance InstantiateFull Constraint where-  instantiateFull' c = case c of+  instantiateFull' = \case     ValueCmp cmp t u v -> do       (t,u,v) <- instantiateFull' (t,u,v)       return $ ValueCmp cmp t u v@@ -1354,18 +1378,19 @@     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)-    TelCmp a b cmp tela telb -> uncurry (TelCmp a b cmp) <$> instantiateFull' (tela,telb)     SortCmp cmp a b     -> uncurry (SortCmp cmp) <$> instantiateFull' (a,b)-    Guarded c pid       -> Guarded <$> instantiateFull' c <*> pure pid     UnBlock m           -> return $ UnBlock m-    FindInstance m b cands -> FindInstance m b <$> mapM instantiateFull' cands+    FindInstance m cs   -> FindInstance m <$> mapM instantiateFull' cs     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 m t g h -> UnquoteTactic m <$> instantiateFull' t <*> instantiateFull' g <*> instantiateFull' h+    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     c@CheckMetaInst{}   -> return c+    UsableAtModality mod t -> UsableAtModality mod <$> instantiateFull' t  instance InstantiateFull CompareAs where   instantiateFull' (AsTermsOf a) = AsTermsOf <$> instantiateFull' a@@ -1378,7 +1403,7 @@ instance InstantiateFull Section where   instantiateFull' (Section tel) = Section <$> instantiateFull' tel -instance (Subst t a, InstantiateFull a) => InstantiateFull (Tele a) where+instance (Subst a, InstantiateFull a) => InstantiateFull (Tele a) where   instantiateFull' EmptyTel = return EmptyTel   instantiateFull' (ExtendTel a b) = uncurry ExtendTel <$> instantiateFull' (a, b) @@ -1404,17 +1429,19 @@ instance InstantiateFull NLPSort where   instantiateFull' (PType x) = PType <$> instantiateFull' x   instantiateFull' (PProp x) = PProp <$> instantiateFull' x-  instantiateFull' PInf      = return PInf+  instantiateFull' (PInf f n) = return $ PInf f n   instantiateFull' PSizeUniv = return PSizeUniv+  instantiateFull' PLockUniv = return PLockUniv  instance InstantiateFull RewriteRule where-  instantiateFull' (RewriteRule q gamma f ps rhs t) =+  instantiateFull' (RewriteRule q gamma f ps rhs t c) =     RewriteRule q       <$> instantiateFull' gamma       <*> pure f       <*> instantiateFull' ps       <*> instantiateFull' rhs       <*> instantiateFull' t+      <*> pure c  instance InstantiateFull DisplayForm where   instantiateFull' (Display n ps v) = uncurry (Display n) <$> instantiateFull' (ps, v)@@ -1448,6 +1475,7 @@       Primitive{ primClauses = cs } -> do         cs <- instantiateFull' cs         return $ d { primClauses = cs }+      PrimitiveSort{} -> return d  instance InstantiateFull ExtLamInfo where   instantiateFull' e@(ExtLamInfo { extLamSys = sys}) = do@@ -1472,17 +1500,18 @@       <*> pure lz  instance InstantiateFull CompiledClauses where-  instantiateFull' Fail        = return Fail+  instantiateFull' (Fail xs)   = return $ Fail xs   instantiateFull' (Done m t)  = Done m <$> instantiateFull' t   instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs  instance InstantiateFull Clause where-    instantiateFull' (Clause rl rf tel ps b t catchall recursive unreachable ell) =+    instantiateFull' (Clause rl rf tel ps b t catchall exact recursive unreachable ell) =        Clause rl rf <$> instantiateFull' tel        <*> instantiateFull' ps        <*> instantiateFull' b        <*> instantiateFull' t        <*> return catchall+       <*> return exact        <*> return recursive        <*> return unreachable        <*> return ell@@ -1490,7 +1519,8 @@ instance InstantiateFull Interface where     instantiateFull' (Interface h s ft ms mod scope inside                                sig display userwarn importwarn b foreignCode-                               highlighting pragmas usedOpts patsyns warnings partialdefs) =+                               highlighting libPragmas filePragmas usedOpts patsyns+                               warnings partialdefs) =         Interface h s ft ms mod scope inside             <$> instantiateFull' sig             <*> instantiateFull' display@@ -1499,7 +1529,8 @@             <*> instantiateFull' b             <*> return foreignCode             <*> return highlighting-            <*> return pragmas+            <*> return libPragmas+            <*> return filePragmas             <*> return usedOpts             <*> return patsyns             <*> return warnings@@ -1510,11 +1541,13 @@     instantiateFull' (Prim x)   = Prim <$> instantiateFull' x  instance InstantiateFull Candidate where-  instantiateFull' (Candidate u t ov) =-    Candidate <$> instantiateFull' u <*> instantiateFull' t <*> pure ov+  instantiateFull' (Candidate q u t ov) =+    Candidate q <$> instantiateFull' u <*> instantiateFull' t <*> pure ov  instance InstantiateFull EqualityView where   instantiateFull' (OtherType t)            = OtherType+    <$> instantiateFull' t+  instantiateFull' (IdiomType t)            = IdiomType     <$> instantiateFull' t   instantiateFull' (EqualityType s eq l t a b) = EqualityType     <$> instantiateFull' s

+ src/full/Agda/TypeChecking/Reduce.hs-boot view

@@ -0,0 +1,6 @@+module Agda.TypeChecking.Reduce where++import Agda.Syntax.Internal (Term, Elims, QName)+import Agda.TypeChecking.Monad.Base (TCM, Reduced)++reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)

src/full/Agda/TypeChecking/Reduce/Fast.hs view

@@ -1,7 +1,4 @@-{-# LANGUAGE BangPatterns  #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeFamilies  #-}  {-| @@ -47,8 +44,9 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.List as List-import Data.Traversable (traverse) import Data.Semigroup ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import System.IO.Unsafe (unsafePerformIO) import Data.IORef@@ -61,20 +59,19 @@ import Agda.Syntax.Literal  import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Irrelevance (isPropM) import Agda.TypeChecking.Monad hiding (Closure(..)) import Agda.TypeChecking.Reduce as R import Agda.TypeChecking.Rewriting (rewrite) import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Monad.Builtin hiding (constructorForm)  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.Utils.Pretty@@ -125,9 +122,11 @@         _      -> False   let irr = isPrp || isIrrelevant (defArgInfo def) +  dontReduce <- not <$> shouldReduceDef (defName def)+   cdefn <-     case theDef def of-      _ | irr -> pure CAxiom+      _ | irr || dontReduce -> pure CAxiom       _ | Just (defName def) == bPrimForce bEnv   -> pure CForce       _ | Just (defName def) == bPrimErase bEnv ->           case telView' (defType def) of@@ -149,9 +148,10 @@       DataOrRecSig{}                 -> pure CAxiom       AbstractDefn{}                 -> pure CAxiom       GeneralizableVar{}             -> __IMPOSSIBLE__+      PrimitiveSort{}                -> pure COther -- TODO       Primitive{ primName = name, primCompiled = cc } ->         case name of-          -- "primShowInteger" -- integers are not literals+          -- "primShowInteger"            -- integers are not literals            -- Natural numbers           "primNatPlus"                -> mkPrim 2 $ natOp (+)@@ -163,39 +163,57 @@           "primNatEquality"            -> mkPrim 2 $ natRel (==)            -- Word64-          "primWord64ToNat"            -> mkPrim 1 $ \ [LitWord64 _ a] -> nat (fromIntegral a)-          "primWord64FromNat"          -> mkPrim 1 $ \ [LitNat _ a]    -> word (fromIntegral a)+          "primWord64ToNat"            -> mkPrim 1 $ \ [LitWord64 a] -> nat (fromIntegral a)+          "primWord64FromNat"          -> mkPrim 1 $ \ [LitNat a]    -> word (fromIntegral a) -          -- Levels are not literals-          -- "primLevelZero"-          -- "primLevelSuc"-          -- "primLevelMax"+          -- Levels+          -- "primLevelZero"              -- levels are not literals+          -- "primLevelSuc"               -- levels are not literals+          -- "primLevelMax"               -- levels are not literals            -- Floats-          "primNatToFloat"             -> mkPrim 1 $ \ [LitNat _ a] -> float (fromIntegral a)+          "primFloatInequality"        -> mkPrim 2 $ floatRel (<=)+          "primFloatEquality"          -> mkPrim 2 $ floatRel (==)+          "primFloatLess"              -> mkPrim 2 $ floatRel (<)+          "primFloatIsInfinite"        -> mkPrim 1 $ floatPred isInfinite+          "primFloatIsNaN"             -> mkPrim 1 $ floatPred isNaN+          "primFloatIsDenormalized"    -> mkPrim 1 $ floatPred isDenormalized+          "primFloatIsNegativeZero"    -> mkPrim 1 $ floatPred isNegativeZero+          "primFloatIsSafeInteger"     -> mkPrim 1 $ floatPred isSafeInteger+          "primFloatToWord64"          -> mkPrim 1 $ \ [LitFloat a] -> word (doubleToWord64 a)+          -- "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 (/)-          "primFloatEquality"          -> mkPrim 2 $ floatRel floatEq-          "primFloatLess"              -> mkPrim 2 $ floatRel floatLt-          "primFloatNumericalEquality" -> mkPrim 2 $ floatRel (==)-          "primFloatNumericalLess"     -> mkPrim 2 $ floatRel (<)           "primFloatSqrt"              -> mkPrim 1 $ floatFun sqrt-          -- "primRound"    -- Integers are not literals-          -- "primFloor"-          -- "primCeiling"-          "primExp"                    -> mkPrim 1 $ floatFun exp-          "primLog"                    -> mkPrim 1 $ floatFun log-          "primSin"                    -> mkPrim 1 $ floatFun sin-          "primCos"                    -> mkPrim 1 $ floatFun cos-          "primTan"                    -> mkPrim 1 $ floatFun tan-          "primASin"                   -> mkPrim 1 $ floatFun asin-          "primACos"                   -> mkPrim 1 $ floatFun acos-          "primATan"                   -> mkPrim 1 $ floatFun atan-          "primATan2"                  -> mkPrim 2 $ floatOp atan2-          "primShowFloat"              -> mkPrim 1 $ \ [LitFloat _ a] -> string (show a)+          "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 (==)@@ -209,27 +227,27 @@           "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 (toEnum $ fromIntegral $ a `mod` 0x110000)+          "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"     -- We don't have the list builtins (but could have, TODO)-          -- "primStringFromList"   -- and they are not literals-          "primStringAppend"           -> mkPrim 2 $ \ [LitString _ a, LitString _ b] -> string (b ++ a)-          "primStringEquality"         -> mkPrim 2 $ \ [LitString _ a, LitString _ b] -> bool (b == a)+          -- "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 (show a)-          -- "primQNameFixity"  -- We don't have fixity builtins (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 (show (pretty a))+          "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@@ -244,38 +262,42 @@           ~(Just false) = bFalse bEnv <&> \ c -> Con c ConOSystem []            bool   a = if a then true else false-          nat    a = Lit . LitNat    noRange $! a-          word   a = Lit . LitWord64 noRange $! a-          float  a = Lit . LitFloat  noRange $! a-          string a = Lit . LitString noRange $! a-          char   a = Lit . LitChar   noRange $! a+          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 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 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 f [LitNat a, LitNat b] = bool (f b a)           natRel _ _ = __IMPOSSIBLE__ -          floatFun f [LitFloat _ a] = float (f a)+          floatFun f [LitFloat a] = float (f a)           floatFun _ _ = __IMPOSSIBLE__ -          floatOp f [LitFloat _ a, LitFloat _ b] = float (f b a)+          floatOp f [LitFloat a, LitFloat b] = float (f b a)           floatOp _ _ = __IMPOSSIBLE__ -          floatRel f [LitFloat _ a, LitFloat _ b] = bool (f b a)+          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 f [LitChar a] = char (f a)           charFun _ _ = __IMPOSSIBLE__ -          charPred f [LitChar _ a] = bool (f a)+          charPred f [LitChar a] = bool (f a)           charPred _ _ = __IMPOSSIBLE__ -          charRel f [LitChar _ a, LitChar _ b] = bool (f b a)+          charRel f [LitChar a, LitChar b] = bool (f b a)           charRel _ _ = __IMPOSSIBLE__    return $@@ -335,7 +357,7 @@ fastCompiledClauses :: BuiltinEnv -> CompiledClauses -> FastCompiledClauses fastCompiledClauses bEnv cc =   case cc of-    Fail              -> FFail+    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)@@ -348,7 +370,7 @@     , 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    = fromMaybe False fT+    , ffallThrough    = (Just True ==) fT     , fcatchAllBranch = fmap (fastCompiledClauses env) wild }   where     stripSuc | Just c <- bSuc env = Map.delete (conName c)@@ -667,12 +689,6 @@ compile :: Normalisation -> Term -> AM s compile nf t = Eval (Closure Unevaled t emptyEnv []) [NormaliseK | nf == NF] --- | The abstract machine treats uninstantiated meta-variables as blocked, but the rest of Agda does---   not.-topMetaIsNotBlocked :: Blocked Term -> Blocked Term-topMetaIsNotBlocked (Blocked _ t@MetaV{}) = notBlocked t-topMetaIsNotBlocked b = b- decodePointer :: Pointer s -> ST s Term decodePointer p = decodeClosure_ =<< derefPointer_ p @@ -697,7 +713,7 @@ decodeClosure (Closure isV t env spine) = do     vs <- decodeEnv env     es <- decodeSpine spine-    return $ topMetaIsNotBlocked (applyE (applySubst (parS vs) t) es <$ b)+    return $ applyE (applySubst (parS vs) t) es <$ b   where     parS = foldr (:#) IdS  -- parallelS is too strict     b    = case isV of@@ -766,12 +782,12 @@         IApply x y r : sp -> go xs sp (r `extendEnv` env)         _            -> __IMPOSSIBLE__ -unusedPointerString :: String-unusedPointerString = show (withFileAndLine Impossible)+unusedPointerString :: Text+unusedPointerString = T.pack (show (withCurrentCallStack Impossible))  unusedPointer :: Pointer s unusedPointer = Pure (Closure (Value $ notBlocked ())-                     (Lit (LitString noRange unusedPointerString)) emptyEnv [])+                     (Lit (LitString unusedPointerString)) emptyEnv [])  -- * Running the abstract machine @@ -792,7 +808,7 @@     getMeta m      = maybe __IMPOSSIBLE__ mvInstantiation (IntMap.lookup (metaId m) metaStore)     partialDefs    = runReduce getPartialDefs     rewriteRules f = cdefRewriteRules (constInfo f)-    callByNeed     = envCallByNeed (redEnv rEnv)+    callByNeed     = envCallByNeed (redEnv rEnv) && not (optCallByName $ redSt rEnv ^. stPragmaOptions)     iview          = runReduce intervalView'      runReduce :: ReduceM a -> a@@ -877,7 +893,7 @@          -- Case: zero. Return value closure with literal 0.         Con c i [] | isZero c ->-          runAM (evalTrueValue (Lit (LitNat noRange 0)) emptyEnv spine ctrl)+          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.@@ -993,8 +1009,8 @@     -- Case: NatSucK m      -- If literal add m to the literal,-    runAM' (Eval cl@(Closure Value{} (Lit (LitNat r n)) _ _) (NatSucK m : ctrl)) =-      runAM (evalTrueValue (Lit $! LitNat r $! m + n) emptyEnv [] ctrl)+    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)) =@@ -1047,7 +1063,7 @@         spine' = spine0 <> [elim] <> spine1         stuck  = Closure (Value blk) (Def pf []) emptyEnv spine' -        isCanonical u = case u of+        isCanonical = \case           Lit{}      -> True           Con{}      -> True           Lam{}      -> True@@ -1110,8 +1126,8 @@             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+          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@@ -1175,7 +1191,7 @@         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 noRange n') emptyEnv []+                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@@ -1266,7 +1282,7 @@           case iview $ ignoreBlocking br of             IZero -> evalPointerAM x es ctrl             IOne  -> evalPointerAM y es ctrl-            _     -> (<* blockedOrMeta br) <$> go es+            _     -> (<* 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.@@ -1310,7 +1326,7 @@       | otherwise = traceDoc ("R" <+> pretty s) $ do         v0 <- decodeClosure_ (Closure Unevaled t env [])         es <- decodeSpine spine-        case runReduce (rewrite blk v0 rewr es) of+        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@@ -1358,7 +1374,7 @@       | speculative          = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl)       | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl)       | otherwise            = runReduce $-          traceSLn "impossible" 10 ("Incomplete pattern matching when applying " ++ show f)+          traceSLn "impossible" 10 ("Incomplete pattern matching when applying " ++ prettyShow f)                    __IMPOSSIBLE__      -- Some helper functions to build machine states and closures.@@ -1379,7 +1395,7 @@  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)+    mparens (p > 0) $ vcat (prettyMap_ cs ++ prettyMap_ ls ++ prSuc suc ++ prC m)     where       prC Nothing = []       prC (Just x) = ["_ ->" <?> pretty x]@@ -1392,7 +1408,7 @@   pretty FFail        = "fail"   pretty (FEta n _ cc ca) =     text ("eta " ++ show n ++ " of") <?>-      vcat ([ "{} ->" <?> pretty cc ] +++      vcat ("{} ->" <?> pretty cc :             [ "_ ->" <?> pretty cc | Just cc <- [ca] ])   pretty (FCase n bs) | fprojPatterns bs =     sep [ text $ "project " ++ show n@@ -1409,7 +1425,7 @@   prettyPrec p = prettyPrec p . unsafeDerefPointer  instance Pretty (Closure s) where-  prettyPrec _ (Closure Value{} (Lit (LitString _ unused)) _ _)+  prettyPrec _ (Closure Value{} (Lit (LitString unused)) _ _)     | unused == unusedPointerString = "_"   prettyPrec p (Closure isV t env spine) =     mparens (p > 9) $ fsep [ text tag

src/full/Agda/TypeChecking/Reduce/Monad.hs view

@@ -12,24 +12,20 @@  import Control.Monad.Reader -import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Maybe  import System.IO.Unsafe -import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Monad hiding   ( enterClosure, isInstantiatedMeta, verboseS, typeOfConst, lookupMeta, lookupMeta', constructorForm ) import Agda.TypeChecking.Substitute -import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.Monad import Agda.Utils.Pretty () --instance only -import Agda.Utils.Impossible  instance HasBuiltins ReduceM where   getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useR stLocalBuiltins)@@ -90,8 +86,14 @@   verboseBracket k n s = applyWhenVerboseS k n $     bracket_ (openVerboseBracket k n s) (const $ closeVerboseBracket k n) +  getVerbosity     = defaultGetVerbosity+  isDebugPrinting  = defaultIsDebugPrinting+  nowDebugPrinting = defaultNowDebugPrinting+ instance HasConstInfo ReduceM where-  getRewriteRulesFor = defaultGetRewriteRulesFor getTCState+  getRewriteRulesFor = defaultGetRewriteRulesFor   getConstInfo' q = do     ReduceEnv env st <- askR     defaultGetConstInfo st env q++instance PureTCM ReduceM where

src/full/Agda/TypeChecking/Rewriting.hs view

@@ -151,9 +151,14 @@    -- Run confluence check for the new rules   -- (should be done after adding all rules, see #3795)-  whenM (optConfluenceCheck <$> pragmaOptions) $-    checkConfluenceOfRules rews-+  whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do+    -- 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+    reportSDoc "rewriting" 10 $+      "done checking confluence of rules" <+> prettyList_ (map (prettyTCM . rewName) rews)  -- | Check the validity of @q : Γ → rel us lhs rhs@ as rewrite rule --   @@@ -204,7 +209,7 @@   let failureFreeVars :: IntSet -> TCM a       failureFreeVars xs = typeError . GenericDocError =<< hsep         [ prettyTCM q , " is not a legal rewrite rule, since the following variables are not bound by the left hand side: " , prettyList_ (map (prettyTCM . var) $ IntSet.toList xs) ]-  let failureIllegalRule :: TCM a+  let failureIllegalRule :: TCM a -- TODO:: Defined but not used       failureIllegalRule = typeError . GenericDocError =<< hsep         [ prettyTCM q , " is not a legal rewrite rule" ] @@ -217,6 +222,7 @@           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 @@ -231,28 +237,26 @@       -- 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) $ normalise lhs+      lhs <- modifyAllowedReductions (const $ SmallSet.singleton InlineReductions) $ reduce lhs -      -- Find head symbol f of the lhs, its type and its arguments.-      (f , hd , t , es) <- case lhs of+      -- 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)+          return (f , Def f , defType def , [] , es)         Con c ci vs -> do           let hd = Con c ci           ~(Just ((_ , _ , pars) , t)) <- getFullyAppliedConType c $ unDom b-          addContext gamma1 $ checkParametersAreGeneral c (size gamma1) pars-          return (conName c , hd , t  , vs)+          pars <- addContext gamma1 $ checkParametersAreGeneral c pars+          return (conName c , hd , t , pars , vs)         _        -> failureNotDefOrCon        ifNotAlreadyAdded f $ do        addContext gamma1 $ do-        -- Normalize lhs args: we do not want to match redexes.-        es <- normalise es -        checkNoLhsReduction f es+        checkNoLhsReduction f hd es          unless (noMetas (es, rhs, b)) $ do           reportSDoc "rewriting" 30 $ "metas in lhs: " <+> text (show $ allMetasList es)@@ -264,16 +268,34 @@         reportSDoc "rewriting" 30 $           "Pattern generated from lhs: " <+> prettyTCM (PDef f ps) -        -- check that FV(rhs) ⊆ nlPatVars(lhs)-        let freeVars  = usedArgs (defArgOccurrences def) `IntSet.union` allFreeVars (ps,rhs)-            boundVars = nlPatVars ps+        -- 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+              _              -> __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 -        let rew = RewriteRule q gamma f ps rhs (unDom b)+        let rew = RewriteRule q gamma f ps rhs (unDom b) False          reportSDoc "rewriting" 10 $ vcat           [ "checked rewrite rule" , prettyTCM rew ]@@ -285,24 +307,30 @@     _ -> failureWrongTarget    where-    checkNoLhsReduction :: QName -> Elims -> TCM ()-    checkNoLhsReduction f es = do-      let v = Def f es+    checkNoLhsReduction :: QName -> (Elims -> Term)  -> Elims -> TCM ()+    checkNoLhsReduction 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+      let v = hd es       v' <- reduce v-      let fail = do+      let fail :: TCM a+          fail = do             reportSDoc "rewriting" 20 $ "v  = " <+> text (show v)             reportSDoc "rewriting" 20 $ "v' = " <+> text (show v')             typeError . GenericDocError =<< fsep               [ prettyTCM q <+> " is not a legal rewrite rule, since the left-hand side "               , prettyTCM v <+> " reduces to " <+> prettyTCM v' ]-      case v' of-        Def f' es' | f == f' -> do-          a   <- computeElimHeadType f es es'-          pol <- getPolarity' CmpEq f-          ok  <- dontAssignMetas $ tryConversion $-                   compareElims pol [] a (Def f []) es es'-          unless ok fail-        _ -> fail+      es' <- case v' of+        Def f' es'   | f == f'         -> return es'+        Con c' _ es' | f == conName c' -> return es'+        _                              -> fail+      unless (null es && null es') $ do+        a   <- computeElimHeadType f es es'+        pol <- getPolarity' CmpEq f+        ok  <- dontAssignMetas $ tryConversion $+                 compareElims pol [] a (Def f []) es es'+        unless ok fail      checkAxFunOrCon :: QName -> Definition -> TCM ()     checkAxFunOrCon f def = case theDef def of@@ -327,23 +355,25 @@           return rew         Nothing -> cont -    usedArgs :: [Pos.Occurrence] -> IntSet-    usedArgs occs = IntSet.fromList $ map snd $ usedIxs+    usedArgs :: Definition -> IntSet+    usedArgs def = IntSet.fromList $ map snd $ usedIxs       where+        occs = defArgOccurrences def         allIxs = zip occs $ downFrom $ size occs         usedIxs = filter (used . fst) allIxs         used Pos.Unused = False         used _          = True -    checkParametersAreGeneral :: ConHead -> Int -> Args -> TCM ()-    checkParametersAreGeneral c k vs = do+    checkParametersAreGeneral :: ConHead -> Args -> TCM [Int]+    checkParametersAreGeneral c vs = do         is <- loop vs         unless (fastDistinct is) $ errorNotGeneral+        return is       where         loop []       = return []         loop (v : vs) = case unArg v of-          Var i [] | i < k -> (i :) <$> loop vs-          _                -> errorNotGeneral+          Var i [] -> (i :) <$> loop vs+          _        -> errorNotGeneral          errorNotGeneral :: TCM a         errorNotGeneral = typeError . GenericDocError =<< vcat@@ -355,60 +385,57 @@ -- | @rewriteWith t f es rew@ where @f : t@ --   tries to rewrite @f es@ with @rew@, returning the reduct if successful. rewriteWith :: Type-            -> Term+            -> (Elims -> Term)             -> RewriteRule             -> Elims             -> ReduceM (Either (Blocked Term) Term)-rewriteWith t v rew@(RewriteRule q gamma _ ps rhs b) es = do+rewriteWith t hd rew@(RewriteRule q gamma _ ps rhs b isClause) es+ | isClause = return $ Left $ NotBlocked ReallyNotBlocked $ hd es+ | otherwise = do   traceSDoc "rewriting.rewrite" 50 (sep-    [ "{ attempting to rewrite term " <+> prettyTCM (v `applyE` es)-    , " having head " <+> prettyTCM v <+> " of type " <+> prettyTCM t+    [ "{ attempting to rewrite term " <+> prettyTCM (hd es)+    , " having head " <+> prettyTCM (hd []) <+> " of type " <+> prettyTCM t     , " with rule " <+> prettyTCM rew     ]) $ do   traceSDoc "rewriting.rewrite" 90 (sep-    [ "raw: attempting to rewrite term " <+> (text . show) (v `applyE` es)-    , " having head " <+> (text . show) v <+> " of type " <+> (text . show) t+    [ "raw: attempting to rewrite term " <+> (text . show) (hd es)+    , " having head " <+> (text . show) (hd []) <+> " of type " <+> (text . show) t     , " with rule " <+> (text . show) rew     ]) $ do-  result <- nonLinMatch gamma (t,v) ps es+  result <- nonLinMatch gamma (t,hd) ps es   case result of     Left block -> traceSDoc "rewriting.rewrite" 50 "}" $-      return $ Left $ block $> v `applyE` es -- TODO: remember reductions+      return $ Left $ block $> hd es -- TODO: remember reductions     Right sub  -> do       let v' = applySubst sub rhs       traceSDoc "rewriting.rewrite" 50 (sep-        [ "rewrote " <+> prettyTCM (v `applyE` es)+        [ "rewrote " <+> prettyTCM (hd es)         , " to " <+> prettyTCM v' <+> "}"         ]) $ do       return $ Right v'  -- | @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_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)-rewrite block v rules es = do+rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+rewrite block hd rules es = do   rewritingAllowed <- optRewriting <$> pragmaOptions   if (rewritingAllowed && not (null rules)) then do-    t <- case v of-      Def f []   -> defType <$> getConstInfo f-      Con c _ [] -> typeOfConst $ conName c-        -- Andreas, 2018-09-08, issue #3211:-        -- discount module parameters for constructor heads-      _ -> __IMPOSSIBLE__+    (_ , t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])     loop block t rules =<< instantiateFull' es -- TODO: remove instantiateFull?   else-    return $ NoReduction (block $> v `applyE` es)+    return $ NoReduction (block $> hd es)   where     loop :: Blocked_ -> Type -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)     loop block t [] es =       traceSDoc "rewriting.rewrite" 20 (sep-        [ "failed to rewrite " <+> prettyTCM (v `applyE` es)+        [ "failed to rewrite " <+> prettyTCM (hd es)         , "blocking tag" <+> text (show block)         ]) $ do-      return $ NoReduction $ block $> v `applyE` es+      return $ NoReduction $ block $> hd es     loop block t (rew:rews) es      | let n = rewArity rew, length es >= n = do           let (es1, es2) = List.genericSplitAt n es-          result <- rewriteWith t v rew es1+          result <- rewriteWith t hd rew es1           case result of             Left (Blocked m u)    -> loop (block `mappend` Blocked m ()) t rews es             Left (NotBlocked _ _) -> loop block t rews es

src/full/Agda/TypeChecking/Rewriting.hs-boot view

@@ -4,4 +4,4 @@ import Agda.TypeChecking.Monad.Base  verifyBuiltinRewrite :: Term -> Type -> TCM ()-rewrite :: Blocked_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)

src/full/Agda/TypeChecking/Rewriting/Clause.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-}  module Agda.TypeChecking.Rewriting.Clause where @@ -13,6 +12,7 @@ import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Monad+import Agda.Utils.Pretty  ------------------------------------------------------------------------ -- * Converting clauses to rewrite rules@@ -20,7 +20,7 @@  -- | Get all the clauses of a definition and convert them to rewrite --   rules.-getClausesAsRewriteRules :: QName -> TCM [RewriteRule]+getClausesAsRewriteRules :: (HasConstInfo m, MonadFresh NameId m) => QName -> m [RewriteRule] getClausesAsRewriteRules f = do   cls <- defClauses <$> getConstInfo f   forMaybeM (zip [1..] cls) $ \(i,cl) -> do@@ -28,10 +28,10 @@     return $ clauseToRewriteRule f clname cl  -- | Generate a sensible name for the given clause-clauseQName :: QName -> Int -> TCM QName+clauseQName :: (HasConstInfo m, MonadFresh NameId m) => QName -> Int -> m QName clauseQName f i = QName (qnameModule f) <$> clauseName (qnameName f) i   where-    clauseName n i = freshName noRange (show n ++ "-clause" ++ show i)+    clauseName n i = freshName noRange (prettyShow n ++ "-clause" ++ show i)  -- | @clauseToRewriteRule f q cl@ converts the clause @cl@ of the --   function @f@ to a rewrite rule with name @q@. Returns @Nothing@@@ -45,6 +45,7 @@   , rewPats    = toNLPat $ namedClausePats cl   , rewRHS     = rhs   , rewType    = unArg $ fromMaybe __IMPOSSIBLE__  $ clauseType cl+  , rewFromClause = True   }  class ToNLPat a b where

src/full/Agda/TypeChecking/Rewriting/Confluence.hs view

@@ -1,11 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE NondecreasingIndentation #-} --- | Checking confluence of rewrite rules.+-- | Checking local or global confluence of rewrite rules. ----- Given a rewrite rule @f ps ↦ v@, we construct critical pairs--- involving this as the main rule by searching for:+-- For checking LOCAL CONFLUENCE of a given rewrite rule @f ps ↦ v@,+-- we construct critical pairs involving this as the main rule by+-- searching for: -- -- 1. *Different* rules @f ps' ↦ v'@ where @ps@ and @ps'@ can be --    unified@.@@ -15,76 +15,122 @@ -- -- Each of these leads to a *critical pair* @v₁ <-- u --> v₂@, which -- should satisfy @v₁ = v₂@.+--+-- For checking GLOBAL CONFLUENCE, we check the following two+-- properties:+--+-- 1. For any two left-hand sides of the rewrite rules that overlap+--    (either at the root position or at a subterm), the most general+--    unifier of the two left-hand sides is again a left-hand side of+--    a rewrite rule. For example, if there are two rules @suc m + n =+--    suc (m + n)@ and @m + suc n = suc (m + n)@, then there should+--    also be a rule @suc m + suc n = suc (suc (m + n))@.+--+-- 2. Each rewrite rule should satisfy the *triangle property*: For+--    any rewrite rule @u = w@ and any single-step parallel unfolding+--    @u => v@, we should have another single-step parallel unfolding+--    @v => w@. -module Agda.TypeChecking.Rewriting.Confluence ( checkConfluenceOfRules , checkConfluenceOfClause ) where +module Agda.TypeChecking.Rewriting.Confluence+  ( checkConfluenceOfRules+  , checkConfluenceOfClauses+  , sortRulesOfSymbol+  ) where+ import Control.Applicative+import Control.Arrow ((***)) import Control.Monad+import Control.Monad.Except import Control.Monad.Reader +import Data.Either import Data.Function ( on ) import Data.Functor ( ($>) )+import qualified Data.HashMap.Strict as HMap import Data.List ( elemIndex , tails )+import Data.Set (Set) import qualified Data.Set as Set +import Agda.Interaction.Options ( ConfluenceCheck(..) )+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars  import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Conversion.Pure import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free-import Agda.TypeChecking.Irrelevance ( workOnTypes )+import Agda.TypeChecking.Irrelevance ( workOnTypes , isIrrelevantOrPropM ) import Agda.TypeChecking.Level import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Pretty.Warning+import Agda.TypeChecking.Pretty.Constraint import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Rewriting.Clause+import Agda.TypeChecking.Rewriting.NonLinMatch import Agda.TypeChecking.Rewriting.NonLinPattern import Agda.TypeChecking.Sort import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings -import Agda.Utils.Except+import Agda.Utils.Applicative+import Agda.Utils.Functor import Agda.Utils.Impossible+import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.ListT import Agda.Utils.Maybe import Agda.Utils.Monad+import Agda.Utils.Null (unlessNullM)+import Agda.Utils.Permutation import Agda.Utils.Singleton import Agda.Utils.Size +-- ^ Check confluence of the clauses of the given function wrt rewrite rules of the+-- constructors they match against+checkConfluenceOfClauses :: ConfluenceCheck -> QName -> TCM ()+checkConfluenceOfClauses confChk f = do+  rews <- getClausesAsRewriteRules f+  let matchables = map getMatchables rews+  reportSDoc "rewriting.confluence" 30 $+    "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+      checkConfluenceOfRules confChk [rew]  -- ^ Check confluence of the given rewrite rules wrt all other rewrite --   rules (also amongst themselves).-checkConfluenceOfRules :: [RewriteRule] -> TCM ()-checkConfluenceOfRules = checkConfluenceOfRules' False---- ^ Check confluence of the given clause wrt rewrite rules of the--- constructors it matches against-checkConfluenceOfClause :: QName -> Int -> Clause -> TCM ()-checkConfluenceOfClause f i cl = do-  fi <- clauseQName f i-  whenJust (clauseToRewriteRule f fi cl) $ \rew -> do-    checkConfluenceOfRules' True [rew]-    let matchables = getMatchables rew-    reportSDoc "rewriting.confluence" 30 $-      "Function" <+> prettyTCM f <+> "has matchable symbols" <+> prettyList_ (map prettyTCM matchables)-    modifySignature $ setMatchableSymbols f matchables+checkConfluenceOfRules :: ConfluenceCheck -> [RewriteRule] -> TCM ()+checkConfluenceOfRules confChk rews = inTopContext $ inAbstractMode $ do -checkConfluenceOfRules' :: Bool -> [RewriteRule] -> TCM ()-checkConfluenceOfRules' isClause 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+         (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)+        checkTrianglePropertyForRule rew    forM_ (tails rews) $ listCase (return ()) $ \rew rewsRest -> do    reportSDoc "rewriting.confluence" 10 $     "Checking confluence of rule" <+> prettyTCM (rewName rew)+  reportSDoc "rewriting.confluence" 30 $+    "Checking confluence of rule" <+> prettyTCM rew    let f   = rewHead rew       qs  = rewPats rew@@ -92,37 +138,48 @@   def <- getConstInfo f   (fa , hdf) <- addContext tel $ makeHead def (rewType rew) +  reportSDoc "rewriting.confluence" 30 $ addContext tel $+    "Head symbol" <+> prettyTCM (hdf []) <+> "of rewrite rule has type" <+> prettyTCM fa+   -- Step 1: check other rewrite rules that overlap at top position-  forMM_ (getRulesFor f isClause) $ \ rew' ->-    unless (any (sameName rew') $ rew:rewsRest) $+  forMM_ (getAllRulesFor f) $ \ rew' -> do+    unless (any (sameRuleName rew') (rew:rewsRest) ||+            (rewFromClause rew && rewFromClause rew')) $       checkConfluenceTop hdf rew rew'+  reportSDoc "rewriting.confluence" 30 $ "Finished step 1 of confluence check of rule" <+> prettyTCM (rewName rew)    -- Step 2: check other rewrite rules that overlap with a subpattern   -- of this rewrite rule   es <- nlPatToTerm qs-  forMM_ (addContext tel $ allHolesList (fa, hdf) es) $ \ hole ->-    caseMaybe (headView $ ohContents hole) __IMPOSSIBLE__ $ \ (g , hdg , _) -> do-      forMM_ (getRulesFor g isClause) $ \rew' ->-        unless (any (sameName rew') rewsRest) $-          checkConfluenceSub hdf hdg rew rew' hole+  forMM_ (addContext tel $ allHolesList (fa, hdf) es) $ \ hole -> do+    let g   = ohHeadName hole+        hdg = ohHead hole+    reportSDoc "rewriting.confluence" 40 $+      "Found hole with head symbol" <+> prettyTCM g+    rews' <- getAllRulesFor g+    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)    -- Step 3: check other rewrite rules that have a subpattern which   -- overlaps with this rewrite rule   forM_ (defMatchable def) $ \ g -> do-    forMM_ (getClausesAndRewriteRulesFor g) $ \ rew' -> do-      unless (any (sameName rew') rewsRest) $ do+    reportSDoc "rewriting.confluence" 40 $+      "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'         def' <- getConstInfo g         (ga , hdg) <- addContext tel' $ makeHead def' (rewType rew')-        forMM_ (addContext tel' $ allHolesList (ga , hdg) es') $ \ hole ->-          caseMaybe (headView $ ohContents hole) __IMPOSSIBLE__ $ \ (f' , _ , _) ->-            when (f == f') $ checkConfluenceSub hdg hdf rew' rew hole+        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)    where -    sameName = (==) `on` rewName-     -- 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 ()@@ -140,14 +197,24 @@         es1 <- applySubst sub1 <$> nlPatToTerm (rewPats rew1)         es2 <- applySubst sub2 <$> nlPatToTerm (rewPats rew2) +        reportSDoc "rewriting.confluence" 30 $ vcat+          [ "checkConfluenceTop" <+> prettyTCM (rewName rew1) <+> prettyTCM (rewName rew2)+          , "  f    = " <+> prettyTCM f+          , "  ctx1 = " <+> prettyTCM (rewContext rew1)+          , "  ctx2 = " <+> prettyTCM (rewContext rew2)+          , "  es1  = " <+> prettyTCM es1+          , "  es2  = " <+> prettyTCM es2+          ]+         -- Make sure we are comparing eliminations with the same arity         -- (see #3810).         let n = min (size es1) (size es2)             (es1' , es1r) = splitAt n es1             (es2' , es2r) = splitAt n es2+            esr           = es1r ++ es2r -            lhs1 = hd $ es1' ++ es2r-            lhs2 = hd $ es2' ++ es1r+            lhs1 = hd $ es1' ++ esr+            lhs2 = hd $ es2' ++ esr              -- Use type of rewrite rule with the most eliminations             a | null es1r = a2@@ -174,24 +241,26 @@            return (rhs1 , rhs2) -        whenJust maybeCriticalPair $ \ (rhs1 , rhs2) ->-          checkCriticalPair a hd (es1' ++ es2r) rhs1 rhs2+        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 hdf hdg rew1 rew2 hole0 =-      traceCall (CheckConfluence (rewName rew1) (rewName rew2)) $-      localTCStateSavingWarnings $ do+    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" 20 $+          "Checking confluence of rules" <+> prettyTCM (rewName rew1) <+>+          "and" <+> prettyTCM (rewName rew2) <+> "at subpattern position"+         sub1 <- makeMetaSubst $ rewContext rew1 -        let f          = rewHead rew1-            bvTel0     = ohBoundVars hole0+        let bvTel0     = ohBoundVars hole0             k          = size bvTel0             b0         = applySubst (liftS k sub1) $ ohType hole0-            (g,_,es0)  = fromMaybe __IMPOSSIBLE__ $ headView $-                           applySubst (liftS k sub1) $ ohContents hole0+            g          = ohHeadName hole0+            es0        = applySubst (liftS k sub1) $ ohElims hole0             qs2        = rewPats rew2          -- If the second rewrite rule has more eliminations than the@@ -210,7 +279,8 @@             ]          let hole      = hole1 `composeHole` hole0-            (g,_,es') = fromMaybe __IMPOSSIBLE__ $ headView $ ohContents hole -- g == rewHead rew2+            g         = ohHeadName hole -- == rewHead rew2+            es'       = ohElims hole             bvTel     = ohBoundVars hole             plug      = ohPlugHole hole @@ -258,66 +328,7 @@            return (rhs1 , rhs2) -        whenJust maybeCriticalPair $ \ (rhs1 , rhs2) ->-          checkCriticalPair a hdf (applySubst sub1 $ plug $ hdg es1) rhs1 rhs2--    headView :: Term -> Maybe (QName, Elims -> Term, Elims)-    headView (Def f es) = Just (f , Def f , es)-    headView (Con c ci es) = Just (conName c , Con c ci , es)-    headView _ = Nothing--    makeHead :: Definition -> Type -> TCM (Type , Elims -> Term)-    makeHead def a = case theDef def of-      Constructor{ conSrcCon = ch } -> do-        ca <- snd . fromMaybe __IMPOSSIBLE__ <$> getFullyAppliedConType ch a-        return (ca , Con ch ConOSystem)-      -- For record projections @f : R Δ → A@, we rely on the invariant-      -- that any clause is fully general in the parameters, i.e. it-      -- is quantified over the parameter telescope @Δ@-      Function { funProjection = Just proj } -> do-        let f          = projOrig proj-            r          = unArg $ projFromType proj-        rtype <- defType <$> getConstInfo r-        TelV ptel _ <- telView rtype-        n <- getContextSize-        let pars :: Args-            pars = raise (n - size ptel) $ teleArgs ptel-        ftype <- defType def `piApplyM` pars-        return (ftype , Def f)-      _ -> return (defType def , Def $ defName def)--    getClausesAndRewriteRulesFor :: QName -> TCM [RewriteRule]-    getClausesAndRewriteRulesFor f =-      (++) <$> getClausesAsRewriteRules f <*> getRewriteRulesFor f--    getRulesFor :: QName -> Bool -> TCM [RewriteRule]-    getRulesFor f isClause-      | isClause  = getRewriteRulesFor f-      | otherwise = getClausesAndRewriteRulesFor 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--    -- Try to run the TCM action, return @Just x@ if it succeeds with-    -- result @x@ or @Nothing@ if it throws a type error. Abort if-    -- there are any constraints.-    tryUnification :: Term -> Term -> TCM a -> TCM (Maybe a)-    tryUnification lhs1 lhs2 f = (Just <$> f)-      `catchError` \case-        err@TypeError{} -> do-          reportSDoc "rewriting.confluence" 20 $ vcat-            [ "Unification failed with error: "-            , nest 2 $ prettyTCM err-            ]-          return Nothing-        err -> throwError err-      `ifNoConstraints` return $ \pid _ -> do-        cs <- getConstraintsForProblem pid-        prettyCs <- prettyInterestingConstraints cs-        warning $ RewriteMaybeNonConfluent lhs1 lhs2 prettyCs-        return Nothing+        whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hdf (applySubst sub1 $ plug $ hdg es1))      checkCriticalPair       :: Type     -- Type of the critical pair@@ -340,18 +351,265 @@         abstractOverMetas ms (a,es,rhs1,rhs2)        addContext gamma $ reportSDoc "rewriting.confluence" 10 $ sep-        [ "Found critical pair: " , nest 2 $ prettyTCM rhs1+        [ "Found critical pair: "+        , nest 2 $ prettyTCM (hd es)+        , " ---> " , nest 2 $ prettyTCM rhs1         , " =?= " , nest 2 $ prettyTCM rhs2         , " : " , nest 2 $ prettyTCM a ]+      reportSDoc "rewriting.confluence" 30 $ do+        gamma <- instantiateFull gamma+        sep [ "Context of critical pair: "+            , nest 2 $ prettyTCM gamma ] -      addContext gamma $ do-          dontAssignMetas $ noConstraints $ equalTerm a rhs1 rhs2-        `catchError` \case-          TypeError s err -> do-            prettyErr <- withTCState (const s) $ prettyTCM err-            warning $ RewriteNonConfluent (hd es) rhs1 rhs2 prettyErr-          err           -> throwError err+      addContext gamma $ case confChk of +        -- Local confluence check: check that critical pair has a+        -- common reduct.+        LocalConfluenceCheck -> do+            dontAssignMetas $ noConstraints $ equalTerm a rhs1 rhs2+          `catchError` \case+            TypeError _ s err -> do+              prettyErr <- withTCState (const s) $ prettyTCM err+              warning $ RewriteNonConfluent (hd es) rhs1 rhs2 prettyErr+            err           -> throwError err++        -- Global confluence check: enforce that MGU is again the LHS+        -- of a rewrite rule (actual global confluence then follows+        -- from the triangle property which was checked before).+        GlobalConfluenceCheck -> do+          (f, t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])++          let checkEqualLHS :: RewriteRule -> TCM Bool+              checkEqualLHS (RewriteRule 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+                        as = applySubst sub $ flattenTel delta+                    reportSDoc "rewriting.confluence.global" 35 $+                      prettyTCM (hd es) <+> "is an instance of the LHS of rule" <+> prettyTCM q <+> "with instantiation" <+> prettyList_ (map prettyTCM us)+                    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+              allDistinctVars :: [(Term,Dom Type)] -> TCM Bool+              allDistinctVars us = do+                us' <- filterM (not <.> isIrrelevantOrPropM . snd) us+                mis <- traverse (\(u,a) -> isEtaVar u (unDom a)) $ us'+                case sequence mis of+                  Just is -> return $ fastDistinct is+                  Nothing -> return False++          rews <- getAllRulesFor f+          let sameRHS = onlyReduceTypes $ pureEqualTerm a rhs1 rhs2+          unlessM (sameRHS `or2M` anyM rews checkEqualLHS) $ addContext gamma $+            warning $ RewriteAmbiguousRules (hd es) rhs1 rhs2++    checkTrianglePropertyForRule :: RewriteRule -> TCM ()+    checkTrianglePropertyForRule (RewriteRule 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)+      -- If present, last element is always equal to u+      caseMaybe (initLast vs) (return ()) $ \(vs',u') -> do+        unless (u == u') __IMPOSSIBLE__+        forM_ vs' $ \v -> unlessM (checkParallelReductionStep b v rhou) $+          warning $ RewriteMissingRule u v rhou++    checkParallelReductionStep :: Type -> Term -> Term -> TCM Bool+    checkParallelReductionStep a u w = do+      reportSDoc "rewriting.confluence.global" 30 $ fsep+        [ "Global confluence: checking if" , prettyTCM u+        , "reduces to" , prettyTCM w , "in one parallel step." ]+      anyListT (parReduce u) $ \v -> do+        reportSDoc "rewriting.confluence.global" 30 $ fsep+          [ prettyTCM u , " reduces to " , prettyTCM v+          ]+        eq <- onlyReduceTypes $ pureEqualTerm a v w+        when eq $ reportSDoc "rewriting.confluence.global" 30 $ fsep+          [ "  which is equal to" , prettyTCM w+          ]+        return eq+++sortRulesOfSymbol :: QName -> TCM ()+sortRulesOfSymbol f = do+    rules <- sortRules =<< getRewriteRulesFor f+    modifySignature $ over sigRewriteRules $ HMap.insert f rules+  where+    sortRules :: PureTCM m => [RewriteRule] -> m [RewriteRule]+    sortRules rs = do+      ordPairs <- deleteLoops . Set.fromList . map (rewName *** rewName) <$>+        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+      reportSDoc "rewriting.confluence.sort" 50 $ "sorted rules: " <+>+        prettyList_ (map (prettyTCM . rewName) $ permute perm rs)+      return $ permute perm rs++    moreGeneralLHS :: PureTCM m => RewriteRule -> RewriteRule -> 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)+          when res $ reportSDoc "rewriting.confluence.sort" 55 $+            "the lhs of " <+> prettyTCM (rewName r1) <+>+            "is more general than the lhs of" <+> prettyTCM (rewName r2)+          return res++    deleteLoops :: Ord a => Set (a,a) -> Set (a,a)+    deleteLoops xs = Set.filter (\(x,y) -> not $ (y,x) `Set.member` xs) xs++makeHead :: PureTCM m => Definition -> Type -> m (Type , Elims -> Term)+makeHead def a = case theDef def of+  Constructor{ conSrcCon = ch } -> do+    ca <- snd . fromMaybe __IMPOSSIBLE__ <$> getFullyAppliedConType ch a+    return (ca , Con ch ConOSystem)+  -- For record projections @f : R Δ → A@, we rely on the invariant+  -- that any clause is fully general in the parameters, i.e. it+  -- is quantified over the parameter telescope @Δ@+  Function { funProjection = Just proj } -> do+    let f          = projOrig proj+        r          = unArg $ projFromType proj+    rtype <- defType <$> getConstInfo r+    TelV ptel _ <- telView rtype+    n <- getContextSize+    let pars :: Args+        pars = raise (n - size ptel) $ teleArgs ptel+    ftype <- defType def `piApplyM` pars+    return (ftype , Def f)+  _ -> return (defType def , Def $ defName def)++sameRuleName :: RewriteRule -> RewriteRule -> Bool+sameRuleName = (==) `on` rewName++-- | Get both clauses and rewrite rules for the given symbol+getAllRulesFor :: (HasConstInfo m, MonadFresh NameId m) => QName -> m [RewriteRule]+getAllRulesFor f = (++) <$> getRewriteRulesFor 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++computingOverlap :: (MonadTCEnv m) => m a -> m a+computingOverlap = locallyTC eConflComputingOverlap $ const True++-- | Try to run the TCM action, return @Just x@ if it succeeds with+--   result @x@ or @Nothing@ if it throws a type error. Abort if there+--   are any constraints.+tryUnification :: Term -> Term -> TCM a -> TCM (Maybe a)+tryUnification lhs1 lhs2 f = computingOverlap (Just <$> f)+  `catchError` \case+    err@TypeError{} -> do+      reportSDoc "rewriting.confluence" 20 $ vcat+        [ "Unification failed with error: "+        , nest 2 $ prettyTCM err+        ]+      return Nothing+    err -> throwError err+  `ifNoConstraints` return $ \pid _ -> do+    cs <- getConstraintsForProblem pid+    prettyCs <- prettyInterestingConstraints cs+    warning $ RewriteMaybeNonConfluent lhs1 lhs2 prettyCs+    return Nothing+++type MonadParallelReduce m =+  ( PureTCM m+  , MonadFresh NameId m+  )++-- | List all possible single-step parallel reductions of the given term.+allParallelReductions :: (MonadParallelReduce m, ParallelReduce a) => a -> m [a]+allParallelReductions = sequenceListT . parReduce++-- | Single-step parallel reduction of a given term.+--   The monad 'm' can be instantiated in multiple ways:+--   * Use 'MaybeT TCM' to get the "optimal reduct" obtained by+--     applying rewrite rules eagerly.+--   * Use 'ListT TCM' to obtain all possible one-step parallel+--     reductions.+class ParallelReduce a where+  parReduce :: (MonadParallelReduce m, MonadPlus m) => a -> m a++  default parReduce+    :: ( MonadParallelReduce m, MonadPlus m+       , Traversable f, a ~ f b, ParallelReduce b)+    => a -> m a+  parReduce = traverse parReduce++-- | Compute possible one-step reductions by applying a rewrite rule+--   at the top-level and reducing all subterms in the position of a+--   variable of the rewrite rule in parallel.+topLevelReductions :: (MonadParallelReduce m, MonadPlus m) => (Elims -> Term) -> Elims -> m Term+topLevelReductions hd es = do+  reportSDoc "rewriting.parreduce" 30 $ "topLevelReductions" <+> prettyTCM (hd es)+  -- 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)+  reportSDoc "rewriting.parreduce" 60 $ "topLevelReductions: trying rule" <+> prettyTCM q+  -- Don't reduce if underapplied+  guard $ length es >= length ps+  let (es0 , es1) = splitAt (length ps) es+  onlyReduceTypes (nonLinMatch gamma (t,hd) ps es0) >>= \case+    -- Matching failed: no reduction+    Left block -> empty+    -- Matching succeeded+    Right sub -> do+      let vs = map (lookupS sub) $ [0..(size gamma-1)]+      sub' <- parallelS <$> parReduce vs+      es1' <- parReduce es1+      let w = (applySubst sub' rhs) `applyE` es1'+      reportSDoc "rewriting.parreduce" 50 $ "topLevelReductions: rewrote" <+> prettyTCM (hd es) <+> "to" <+> prettyTCM w+      return w++instance ParallelReduce Term where+  parReduce = \case+    -- Interesting cases+    (Def f es) -> (topLevelReductions (Def f) es) <|> (Def f <$> parReduce es)+    (Con c ci es) -> (topLevelReductions (Con c ci) es) <|> (Con c ci <$> parReduce es)++    -- Congruence cases+    Lam i u  -> Lam i <$> parReduce u+    Var x es -> Var x <$> parReduce es+    Pi a b   -> Pi    <$> parReduce a <*> parReduce b+    Sort s   -> Sort  <$> parReduce s++    -- Base cases+    u@Lit{}      -> return u+    u@Level{}    -> return u -- TODO: is this fine?+    u@DontCare{} -> return u+    u@Dummy{}    -> return u -- not __IMPOSSIBLE__ because of presence of Dummy+                             -- parameters for rewrite rules on constructors.++    -- Impossible cases+    MetaV{}    -> __IMPOSSIBLE__++instance ParallelReduce Sort where+  parReduce = pure -- TODO: is this fine?++instance ParallelReduce a => ParallelReduce (Arg a) where+instance ParallelReduce a => ParallelReduce (Dom a) where+instance ParallelReduce a => ParallelReduce (Type' a) where+instance ParallelReduce a => ParallelReduce [a] where++instance ParallelReduce a => ParallelReduce (Elim' a) where+  parReduce (Apply u)  = Apply <$> parReduce u+  parReduce e@Proj{}   = pure e+  parReduce IApply{}   = __IMPOSSIBLE__ -- not yet supported++instance (Free a, Subst a, ParallelReduce a) => ParallelReduce (Abs a) where+  parReduce = mapAbstraction __DUMMY_DOM__ parReduce++ -- | Given metavariables ms and some x, construct a telescope Γ and --   replace all occurrences of the given metavariables in @x@ by --   normal variables from Γ. Returns @Nothing@ if metas have cyclic@@ -379,12 +637,25 @@   { ohBoundVars :: Telescope     -- Telescope of bound variables at the hole   , ohType      :: Type          -- Type of the term in the hole   , ohPlugHole  :: Term -> a     -- Plug the hole with some term-  , ohContents  :: Term          -- The term in the hole+  , ohHead      :: Elims -> Term -- The head symbol of the term in the hole+  , ohElims     :: Elims         -- The eliminations of the term in the hole   } deriving (Functor) +ohHeadName :: OneHole a -> QName+ohHeadName oh = case ohHead oh [] of+  Def f _   -> f+  Con c _ _ -> conName c+  _         -> __IMPOSSIBLE__++ohContents :: OneHole a -> Term+ohContents oh = ohHead oh $ ohElims oh+ -- | The trivial hole idHole :: Type -> Term -> OneHole Term-idHole a v = OneHole EmptyTel a id v+idHole a = \case+  Def f es    -> OneHole EmptyTel a id (Def f) es+  Con c ci es -> OneHole EmptyTel a id (Con c ci) es+  _           -> __IMPOSSIBLE__  -- | Plug a hole with another hole composeHole :: OneHole Term -> OneHole a -> OneHole a@@ -392,7 +663,8 @@   { ohBoundVars = ohBoundVars outer `abstract` ohBoundVars inner   , ohType      = ohType inner   , ohPlugHole  = ohPlugHole outer . ohPlugHole inner-  , ohContents  = ohContents inner+  , ohHead      = ohHead inner+  , ohElims     = ohElims inner   }  ohAddBV :: ArgName -> Dom Type -> OneHole a -> OneHole a@@ -400,19 +672,17 @@  -- ^ Given a @p : a@, @allHoles p@ lists all the possible --   decompositions @p = p'[(f ps)/x]@.-class (Subst Term p , Free p) => AllHoles p where+class (TermSubst p, Free p) => AllHoles p where   type PType p-  allHoles :: (Alternative m , MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m)-           => PType p -> p -> m (OneHole p)+  allHoles :: (Alternative m, PureTCM m) => PType p -> p -> m (OneHole p)  allHoles_-  :: ( Alternative m , MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m, MonadDebug m-     , AllHoles p , PType p ~ () )+  :: ( Alternative m , PureTCM m , AllHoles p , PType p ~ () )   => p -> m (OneHole p) allHoles_ = allHoles ()  allHolesList-  :: ( MonadReduce m, MonadAddContext m, HasBuiltins m, HasConstInfo m , AllHoles p)+  :: ( PureTCM m , AllHoles p)   => PType p -> p -> m [OneHole p] allHolesList a = sequenceListT . allHoles a @@ -561,8 +831,10 @@   allHoles _ = \case     Type l       -> fmap Type <$> allHoles_ l     Prop l       -> fmap Prop <$> allHoles_ l-    Inf          -> empty+    Inf f n      -> empty+    SSet l       -> fmap SSet <$> allHoles_ l     SizeUniv     -> empty+    LockUniv     -> empty     PiSort{}     -> __IMPOSSIBLE__     FunSort{}    -> __IMPOSSIBLE__     UnivSort{}   -> __IMPOSSIBLE__@@ -585,17 +857,9 @@  instance AllHoles PlusLevel where   type PType PlusLevel = ()-  allHoles _ (Plus n l) = fmap (Plus n) <$> allHoles_ l--instance AllHoles LevelAtom where-  type PType LevelAtom = ()-  allHoles _ l = do+  allHoles _ (Plus n l) = do     la <- levelType-    case l of-      MetaLevel{}      -> __IMPOSSIBLE__-      BlockedLevel{}   -> __IMPOSSIBLE__-      NeutralLevel b u -> fmap (NeutralLevel b) <$> allHoles la u-      UnreducedLevel u -> fmap UnreducedLevel <$> allHoles la u+    fmap (Plus n) <$> allHoles la l   -- | Convert metavariables to normal variables. Warning: doesn't@@ -624,13 +888,13 @@   metasToVars = \case     Var i es   -> Var i    <$> metasToVars es     Lam i u    -> Lam i    <$> metasToVars u-    Lit l      -> Lit      <$> pure l+    Lit l      -> pure (Lit l)     Def f es   -> Def f    <$> metasToVars es     Con c i es -> Con c i  <$> metasToVars es     Pi a b     -> Pi       <$> metasToVars a <*> metasToVars b     Sort s     -> Sort     <$> metasToVars s     Level l    -> Level    <$> metasToVars l-    MetaV x es -> ($ x) <$> ask >>= \case+    MetaV x es -> asks ($ x) >>= \case       Just i   -> Var i    <$> metasToVars es       Nothing  -> MetaV x  <$> metasToVars es     DontCare u -> DontCare <$> metasToVars u@@ -643,9 +907,11 @@   metasToVars = \case     Type l     -> Type     <$> metasToVars l     Prop l     -> Prop     <$> metasToVars l-    Inf        -> pure Inf+    Inf f n    -> pure $ Inf f n+    SSet l     -> SSet     <$> metasToVars l     SizeUniv   -> pure SizeUniv-    PiSort s t -> PiSort   <$> metasToVars s <*> metasToVars t+    LockUniv   -> pure LockUniv+    PiSort s t u -> PiSort   <$> 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@@ -657,13 +923,6 @@  instance MetasToVars PlusLevel where   metasToVars (Plus n x) = Plus n <$> metasToVars x--instance MetasToVars LevelAtom where-  metasToVars = \case-    MetaLevel m es    -> NeutralLevel mempty <$> metasToVars (MetaV m es)-    BlockedLevel _ u  -> UnreducedLevel      <$> metasToVars u-    NeutralLevel nb u -> NeutralLevel nb     <$> metasToVars u-    UnreducedLevel u  -> UnreducedLevel      <$> metasToVars u  instance MetasToVars a => MetasToVars (Tele a) where   metasToVars EmptyTel = pure EmptyTel

src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE UndecidableInstances     #-}  {- |  Non-linear matching of the lhs of a rewrite rule against a       neutral term.@@ -23,13 +22,18 @@  import Prelude hiding (null, sequence) +import Control.Applicative (Alternative)+import Control.Monad.Except import Control.Monad.State +import qualified Control.Monad.Fail as Fail+ import Data.Maybe import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet+import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -50,7 +54,6 @@ import Agda.TypeChecking.Telescope  import Agda.Utils.Either-import Agda.Utils.Except import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List@@ -62,9 +65,23 @@  import Agda.Utils.Impossible + -- | Monad for non-linear matching.-type NLM = ExceptT Blocked_ (StateT NLMState ReduceM)+newtype NLM a = NLM { unNLM :: ExceptT Blocked_ (StateT NLMState ReduceM) a }+  deriving ( Functor, Applicative, Monad, Fail.MonadFail+           , Alternative, MonadPlus+           , MonadError Blocked_, MonadState NLMState+           , HasBuiltins, HasConstInfo, HasOptions, ReadTCState+           , MonadTCEnv, MonadReduce, MonadAddContext, MonadDebug+           , PureTCM+           ) +instance MonadBlock NLM where+  patternViolation b = throwError $ Blocked b ()+  catchPatternErr h f = catchError f $ \case+    Blocked b _      -> h b+    err@NotBlocked{} -> throwError err+ data NLMState = NLMState   { _nlmSub   :: Sub   , _nlmEqs   :: PostponedEquations@@ -82,7 +99,7 @@  runNLM :: (MonadReduce m) => NLM () -> m (Either Blocked_ NLMState) runNLM nlm = do-  (ok,out) <- liftReduce $ runStateT (runExceptT nlm) empty+  (ok,out) <- liftReduce $ runStateT (runExceptT $ unNLM nlm) empty   case ok of     Left block -> return $ Left block     Right _    -> return $ Right out@@ -137,22 +154,28 @@   match r gamma k t p v = let r' = r `composeRelevance` getRelevance p                           in  match r' gamma k (unDom t) (unArg p) (unArg v) -instance Match (Type, Term) [Elim' NLPat] Elims where+instance Match (Type, Elims -> Term) [Elim' NLPat] Elims where   match r gamma k (t, hd) [] [] = return ()   match r gamma k (t, hd) [] _  = matchingBlocked $ NotBlocked ReallyNotBlocked ()   match r gamma k (t, hd) _  [] = matchingBlocked $ NotBlocked ReallyNotBlocked ()-  match r gamma k (t, hd) (p:ps) (v:vs) = case (p,v) of+  match r gamma k (t, hd) (p:ps) (v:vs) =+   traceSDoc "rewriting.match" 50 (sep+     [ "matching elimination " <+> addContext (gamma `abstract` k) (prettyTCM p)+     , "  with               " <+> addContext k (prettyTCM v)+     , "  eliminating head   " <+> addContext k (prettyTCM $ hd []) <+> ":" <+> addContext k (prettyTCM t)]) $ do+   case (p,v) of     (Apply p, Apply v) -> do-      ~(Pi a b) <- unEl <$> reduce t+      ~(Pi a b) <- addContext k $ unEl <$> reduce t       match r gamma k a p v-      t' <- addContext k $ t `piApplyM` v-      let hd' = hd `apply` [ v ]+      let t'  = absApp b (unArg v)+          hd' = hd . (Apply v:)       match r gamma k (t',hd') ps vs      (Proj o f, Proj o' f') | f == f' -> do-      ~(Just (El _ (Pi a b))) <- getDefType f =<< reduce t-      let t' = b `absApp` hd-      hd' <- addContext k $ applyDef o f (argFromDom a $> hd)+      ~(Just (El _ (Pi a b))) <- addContext k $ getDefType f =<< reduce t+      let u = hd []+          t' = b `absApp` u+      hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u)       match r gamma k (t',hd') ps vs      (Proj _ f, Proj _ f') | otherwise -> do@@ -176,7 +199,7 @@  instance Match () NLPSort Sort where   match r gamma k _ p s = do-    bs <- reduceB s+    bs <- addContext k $ reduceB s     let b = void bs         s = ignoreBlocking bs         yes = return ()@@ -187,14 +210,16 @@     case (p , s) of       (PType lp  , Type l  ) -> match r gamma k () lp l       (PProp lp  , Prop l  ) -> match r gamma k () lp l-      (PInf      , Inf     ) -> yes+      (PInf fp np , Inf f n)+        | fp == f, np == n   -> yes       (PSizeUniv , SizeUniv) -> yes+      (PLockUniv , LockUniv) -> yes        -- blocked cases       (_ , UnivSort{}) -> matchingBlocked b       (_ , PiSort{}  ) -> matchingBlocked b       (_ , FunSort{} ) -> matchingBlocked b-      (_ , MetaS m _ ) -> matchingBlocked $ Blocked m ()+      (_ , MetaS m _ ) -> matchingBlocked $ blocked_ m        -- all other cases do not match       (_ , _) -> no@@ -215,7 +240,7 @@         prettyTerm = withShowAllArguments $ addContext k $ prettyTCM v         prettyType = withShowAllArguments $ addContext k $ prettyTCM t     etaRecord <- addContext k $ isEtaRecordType t-    prop <- addContext k $ isPropM t+    prop <- fromRight __IMPOSSIBLE__ <.> runBlocked . addContext k $ isPropM t     let r = if prop then Irrelevant else r0     traceSDoc "rewriting.match" 30 (sep       [ "matching pattern " <+> prettyPat@@ -245,8 +270,8 @@           traceSDoc "rewriting.match" 30 (sep             [ "blocking tag from reduction: " <+> text (show b') ]) $ do           matchingBlocked (b `mappend` b')-        maybeBlock w = case w of-          MetaV m es -> matchingBlocked $ Blocked m ()+        maybeBlock = \case+          MetaV m es -> matchingBlocked $ blocked_ m           _          -> no ""     case p of       PVar i bvs -> traceSDoc "rewriting.match" 60 ("matching a PVar: " <+> text (show i)) $ do@@ -263,8 +288,8 @@           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+            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@@ -273,11 +298,11 @@           Def f' es             | f == f'   -> do                 ft <- addContext k $ defType <$> getConstInfo f-                match r gamma k (ft , Def f []) ps es+                match r gamma k (ft , Def f) ps es           Con c ci vs             | f == conName c -> do                 ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-                match r gamma k (ct , Con c ci []) ps vs+                match r gamma k (ct , Con c ci) ps vs           _ | Pi a b <- unEl t -> do             let ai    = domInfo a                 pbody = PDef f $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]@@ -298,16 +323,13 @@                 ps'                   | conName c == f = ps                   | otherwise      = map (Apply . fmap mkField) flds-            match r gamma k (ct, Con c ci []) ps' (map Apply vs)-          MetaV m es -> do-            matchingBlocked $ Blocked m ()+            match r gamma k (ct, Con c ci) ps' (map Apply vs)           v -> maybeBlock v       PLam i p' -> case unEl t of         Pi a b -> do           let body = raise 1 v `apply` [Arg i (var 0)]               k'   = ExtendTel a (Abs (absName b) k)           match r gamma k' (absBody b) (absBody p') body-        MetaV m es -> matchingBlocked $ Blocked m ()         v -> maybeBlock v       PPi pa pb -> case v of         Pi a b -> do@@ -321,7 +343,7 @@       PBoundVar i ps -> case v of         Var i' es | i == i' -> do           let ti = unDom $ indexWithDefault __IMPOSSIBLE__ (flattenTel k) i-          match r gamma k (ti , var i) ps es+          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 ]@@ -334,7 +356,7 @@           ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t           let flds = map argFromDom $ recFields def               ps'  = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds-          match r gamma k (ct, Con c ci []) (map Apply ps') (map Apply vs)+          match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs)         v -> maybeBlock v       PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext (gamma `abstract` k) (prettyTCM u)) $         tellEq gamma k t u v@@ -351,8 +373,8 @@   case IntMap.foldr pickFree NotFree mxs of     MaybeFree ms       | null ms   -> return $ Right Nothing-      | otherwise -> return $ Left $-        foldrMetaSet (\ m -> mappend $ Blocked m ()) (notBlocked ()) ms+      | otherwise -> return $ Left $ Blocked blocker ()+      where blocker = unblockOnAll $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms     NotFree -> return $ Right (Just v')    where@@ -370,14 +392,14 @@  makeSubstitution :: Telescope -> Sub -> Substitution makeSubstitution gamma sub =-  prependS __IMPOSSIBLE__ (map val [0 .. size gamma-1]) IdS+  parallelS $ map (fromMaybe __DUMMY_TERM__ . val) [0 .. size gamma-1]     where       val i = case IntMap.lookup i sub of                 Just (Irrelevant, v) -> Just $ dontCare v                 Just (_         , v) -> Just v                 Nothing              -> Nothing -checkPostponedEquations :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, MonadDebug m)+checkPostponedEquations :: PureTCM m                         => Substitution -> PostponedEquations -> m (Maybe Blocked_) checkPostponedEquations sub eqs = forM' eqs $   \ (PostponedEquation k a lhs rhs) -> do@@ -388,7 +410,7 @@       addContext k $ equal a lhs' rhs  -- main function-nonLinMatch :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m, MonadDebug m, Match t a b)+nonLinMatch :: (PureTCM m, Match t a b)             => Telescope -> t -> a -> b -> m (Either Blocked_ Substitution) nonLinMatch gamma t p v = do   let no msg b = traceSDoc "rewriting.match" 10 (sep@@ -406,17 +428,30 @@ -- | Typed βη-equality, also handles empty record types. --   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 :: (MonadReduce m, MonadAddContext m, HasConstInfo m, HasBuiltins m)-      => Type -> Term -> Term -> m (Maybe Blocked_)-equal a u v = pureEqualTerm a u v >>= \case-  True -> return Nothing-  False -> traceSDoc "rewriting.match" 10 (sep+equal :: PureTCM m => Type -> Term -> Term -> m (Maybe Blocked_)+equal a u v = runBlocked (pureEqualTerm a u v) >>= \case+  Left b      -> return $ Just $ Blocked b ()+  Right True  -> return Nothing+  Right False -> traceSDoc "rewriting.match" 10 (sep       [ "mismatch between " <+> prettyTCM u       , " and " <+> prettyTCM v       ]) $ do-    return $ Just block+    return $ Just $ NotBlocked ReallyNotBlocked () -  where-    block = caseMaybe (firstMeta (u, v))-              (NotBlocked ReallyNotBlocked ())-              (\m -> Blocked m ())+-- | Utility function for getting the name and type of a head term (i.e. a+--   `Def` or `Con` with no arguments)+getTypedHead :: PureTCM m => Term -> m (Maybe (QName, Type))+getTypedHead = \case+  Def f []   -> Just . (f,) . defType <$> getConstInfo f+  Con (ConHead { conName = c }) _ [] -> do+    -- Andreas, 2018-09-08, issue #3211:+    -- discount module parameters for constructor heads+    vs <- freeVarsToApply c+    -- Jesper, 2020-06-17, issue #4755: add dummy arguments in+    -- case we don't have enough parameters+    npars <- fromMaybe __IMPOSSIBLE__ <$> getNumberOfParameters c+    let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__+    t0 <- defType <$> getConstInfo c+    t <- t0 `piApplyM` (vs ++ ws)+    return $ Just (c , t)+  _ -> return Nothing

src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies #-}  {- | Various utility functions dealing with the non-linear, higher-order      patterns used for rewrite rules.@@ -22,13 +21,13 @@ import Agda.TypeChecking.Irrelevance (workOnTypes, isPropM) import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +import Agda.Utils.Either import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.List@@ -85,9 +84,11 @@     case s of       Type l   -> PType <$> patternFrom r k () l       Prop l   -> PProp <$> patternFrom r k () l-      Inf      -> return PInf+      Inf f n  -> return $ PInf f n+      SSet l   -> __IMPOSSIBLE__       SizeUniv -> return PSizeUniv-      PiSort _ _ -> __IMPOSSIBLE__+      LockUniv -> return PLockUniv+      PiSort _ _ _ -> __IMPOSSIBLE__       FunSort _ _ -> __IMPOSSIBLE__       UnivSort _ -> __IMPOSSIBLE__       MetaS{}  -> __IMPOSSIBLE__@@ -109,7 +110,7 @@   patternFrom r0 k t v = do     t <- reduce t     etaRecord <- isEtaRecordType t-    prop <- isPropM t+    prop <- fromRight __IMPOSSIBLE__ <.> runBlocked $ isPropM t     let r = if prop then Irrelevant else r0     v <- unLevel =<< reduce v     reportSDoc "rewriting.build" 60 $ sep@@ -179,13 +180,11 @@ -- | Convert from a non-linear pattern to a term.  class NLPatToTerm p a where-  nlPatToTerm-    :: (MonadReduce m, HasBuiltins m, HasConstInfo m, MonadDebug m)-    => p -> m a+  nlPatToTerm :: PureTCM m => p -> m a    default nlPatToTerm ::     ( NLPatToTerm p' a', Traversable f, p ~ f p', a ~ f a'-    , MonadReduce m, HasBuiltins m, HasConstInfo m, MonadDebug m+    , PureTCM m     ) => p -> m a   nlPatToTerm = traverse nlPatToTerm @@ -219,8 +218,9 @@ instance NLPatToTerm NLPSort Sort where   nlPatToTerm (PType l) = Type <$> nlPatToTerm l   nlPatToTerm (PProp l) = Prop <$> nlPatToTerm l-  nlPatToTerm PInf      = return Inf+  nlPatToTerm (PInf f n) = return $ Inf f n   nlPatToTerm PSizeUniv = return SizeUniv+  nlPatToTerm PLockUniv = return LockUniv  -- | Gather the set of pattern variables of a non-linear pattern class NLPatVars a where@@ -239,8 +239,9 @@   nlPatVarsUnder k = \case     PType l   -> nlPatVarsUnder k l     PProp l   -> nlPatVarsUnder k l-    PInf      -> empty+    PInf f n  -> empty     PSizeUniv -> empty+    PLockUniv -> empty  instance NLPatVars NLPat where   nlPatVarsUnder k = \case@@ -294,8 +295,9 @@   getMatchables = \case     PType l   -> getMatchables l     PProp l   -> getMatchables l-    PInf      -> empty+    PInf f n  -> empty     PSizeUniv -> empty+    PLockUniv -> empty  instance GetMatchables Term where   getMatchables = getDefs' __IMPOSSIBLE__ singleton@@ -318,7 +320,7 @@  instance Free NLPType where   freeVars' (NLPType s a) =-    ifM ((IgnoreNot ==) <$> asks feIgnoreSorts)+    ifM (asks ((IgnoreNot ==) . feIgnoreSorts))       {- then -} (freeVars' (s, a))       {- else -} (freeVars' a) @@ -326,5 +328,6 @@   freeVars' = \case     PType l   -> freeVars' l     PProp l   -> freeVars' l-    PInf      -> mempty+    PInf f n  -> mempty     PSizeUniv -> mempty+    PLockUniv -> mempty

src/full/Agda/TypeChecking/Rules/Application.hs view

@@ -10,21 +10,20 @@  import Prelude hiding ( null ) -import Control.Arrow (first)+import Control.Applicative ((<|>))+import Control.Monad.Except import Control.Monad.Trans import Control.Monad.Trans.Maybe import Control.Monad.Reader +import Data.Bifunctor import Data.Maybe-import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Either (partitionEithers)-import Data.Traversable (sequenceA) import Data.Void-import qualified Data.IntSet as IntSet+import qualified Data.Foldable as Fold+import qualified Data.IntSet   as IntSet -import Agda.Interaction.Highlighting.Generate (storeDisambiguatedName)+import Agda.Interaction.Highlighting.Generate+  ( storeDisambiguatedConstructor, storeDisambiguatedProjection ) import Agda.Interaction.Options  import qualified Agda.Syntax.Abstract as A@@ -32,7 +31,6 @@ import qualified Agda.Syntax.Info as A import Agda.Syntax.Concrete.Pretty () -- only Pretty instances import Agda.Syntax.Common-import Agda.Syntax.Fixity import Agda.Syntax.Internal as I import Agda.Syntax.Position @@ -51,7 +49,6 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Rules.Def@@ -60,10 +57,11 @@ import Agda.TypeChecking.Telescope  import Agda.Utils.Either-import Agda.Utils.Except import Agda.Utils.Functor import Agda.Utils.Lens-import Agda.Utils.List+import Agda.Utils.List  ( (!!!), groupOn, initWithDefault )+import Agda.Utils.List1 ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -80,6 +78,20 @@ -- | Ranges of checked arguments, where present. type MaybeRanges = [Maybe Range] +acHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> [Constraint]+acHeadConstraints hd ACState{acElims = es, acConstraints = cs} = go hd es cs+  where+    go hd [] [] = []+    go hd (e : es) (c : cs) = maybe id (\ c -> (lazyAbsApp c (hd []) :)) c $ go (hd . (e :)) es cs+    go _  [] (_:_) = __IMPOSSIBLE__+    go _  (_:_) [] = __IMPOSSIBLE__++checkHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> TCM Term+checkHeadConstraints hd st = do+  mapM_ solveConstraint_ (acHeadConstraints hd st)+  return $ hd (acElims st)++ -- | @checkApplication hd args e t@ checks an application. --   Precondition: @Application hs args = appView e@ --@@ -106,7 +118,7 @@     ]   case unScope hd of     -- Subcase: unambiguous projection-    A.Proj _ p | Just _ <- getUnambiguous p -> checkHeadApplication cmp e t hd args+    A.Proj o p | Just x <- getUnambiguous p -> checkUnambiguousProjectionApplication cmp e t x o hd args      -- Subcase: ambiguous projection     A.Proj o p -> checkProjApp cmp e o (unAmbQ p) args t@@ -141,11 +153,12 @@     -- Subcase: macro     A.Macro x -> do       -- First go: no parameters-      TelV tel _ <- telView =<< normalise . defType =<< instantiateDef =<< getConstInfo x+      TelV tel _ <- telView . defType =<< instantiateDef =<< getConstInfo x        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            -- inspect macro type to figure out if arguments need to be wrapped in quote/quoteTerm@@ -161,9 +174,9 @@           makeArgs :: [Dom (String, Type)] -> [NamedArg A.Expr] -> ([NamedArg A.Expr], [NamedArg A.Expr])           makeArgs [] args = ([], args)           makeArgs _  []   = ([], [])-          makeArgs tel@(d : _) (arg : args) =+          makeArgs tel@(d : tel1) (arg : args) =             case insertImplicit arg tel of-              NoInsertNeeded -> first (mkArg (snd $ unDom d) arg :) $ makeArgs (tail tel) args+              NoInsertNeeded -> first (mkArg (snd $ unDom d) arg :) $ makeArgs tel1 args               ImpInsert is   -> makeArgs (drop (length is) tel) (arg : args)               BadImplicits   -> (arg : args, [])  -- fail later in checkHeadApplication               NoSuchName{}   -> (arg : args, [])  -- ditto@@ -190,7 +203,7 @@           tel    <- metaTel args                    -- (x : X) (y : Y x)           target <- addContext tel newTypeMeta_      -- Z x y           let holeType = telePi_ tel target         -- (x : X) (y : Y x) → Z x y-          (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ ExpandLast (getRange args) args tel+          (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ CmpLeq ExpandLast (getRange args) args tel                                                     -- a b : (x : X) (y : Y x)           let rho = reverse (map unArg vs) ++# IdS  -- [x := a, y := b]           equalType (applySubst rho target) t       -- Z a b == A@@ -221,18 +234,24 @@   t <- workOnTypes $ newTypeMeta_   v <- checkExpr' CmpEq e t   return (v, t)-inferApplication exh hd args e = postponeInstanceConstraints $+inferApplication exh hd args e = postponeInstanceConstraints $ do+  SortKit{..} <- sortKit   case unScope hd of     A.Proj o p | isAmbiguous p -> inferProjApp e o (unAmbQ p) args+    A.Def' x s | x == nameOfSet      -> inferSet e x s args+    A.Def' x s | x == nameOfProp     -> inferProp e x s args+    A.Def' x s | x == nameOfSSet     -> inferSSet e x s args+    A.Def' x s | x == nameOfSetOmega IsFibrant -> inferSetOmega e x IsFibrant s args+    A.Def' x s | x == nameOfSetOmega IsStrict  -> inferSetOmega e x IsStrict s args     _ -> do       (f, t0) <- inferHead hd       let r = getRange hd-      res <- runExceptT $ checkArgumentsE exh (getRange hd) args t0 Nothing+      res <- runExceptT $ checkArgumentsE CmpEq exh (getRange hd) args t0 Nothing       case res of-        Right (_, vs, t1, _) -> (,t1) <$> unfoldInlined (f vs)+        Right st@(ACState{acType = t1}) -> fmap (,t1) $ unfoldInlined =<< checkHeadConstraints f st         Left problem -> do           t <- workOnTypes $ newTypeMeta_-          v <- postponeArgs problem exh r args t $ \ _ vs _ _ -> unfoldInlined (f vs)+          v <- postponeArgs problem CmpEq exh r args t $ \ st -> unfoldInlined =<< checkHeadConstraints f st           return (v, t)  -----------------------------------------------------------------------------@@ -277,7 +296,8 @@        return (applyE u, unDom a) -    A.Def x -> inferHeadDef ProjPrefix x+    A.Def x  -> inferHeadDef ProjPrefix x+    A.Def'{} -> __IMPOSSIBLE__ -- handled in checkHeadApplication and inferApplication      A.Proj o ambP | Just d <- getUnambiguous ambP -> inferHeadDef o d     A.Proj{} -> __IMPOSSIBLE__ -- inferHead will only be called on unambiguous projections@@ -406,7 +426,12 @@ checkQuantity' :: QName -> Definition -> TCM (Maybe TypeError) checkQuantity' x def = do   case getQuantity def of-    Quantityω{} -> return Nothing -- Abundant definitions can be used in any context.+    dq@Quantityω{} -> do+      reportSDoc "tc.irr" 50 $ vcat+        [ "declaration quantity =" <+> text (show dq)+        -- , "context     quantity =" <+> text (show q)+        ]+      return Nothing -- Abundant definitions can be used in any context.     dq -> do       q <- asksTC getQuantity       reportSDoc "tc.irr" 50 $ vcat@@ -441,6 +466,7 @@ -- 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   sharp <- fmap nameOfSharp <$> coinductionKit   conId  <- getNameOfConstrained builtinConId   pOr    <- getNameOfConstrained builtinPOr@@ -450,6 +476,12 @@   mglue  <- getNameOfConstrained builtin_glue   mglueU  <- getNameOfConstrained builtin_glueU   case hd of+    A.Def' c s | c == nameOfSet      -> checkSet cmp e t c s args+    A.Def' c s | c == nameOfProp     -> checkProp cmp e t c s args+    A.Def' c s | c == nameOfSSet     -> checkSSet cmp e t c s args+    A.Def' c s | c == nameOfSetOmega IsFibrant -> checkSetOmega cmp e t c IsFibrant s args+    A.Def' c s | c == nameOfSetOmega IsStrict  -> checkSetOmega cmp e t c IsStrict s args+     -- Type checking #. The # that the user can write will be a Def, but the     -- sharp we generate in the body of the wrapper is a Con.     A.Def c | Just c == sharp -> checkSharpApplication e t c args@@ -471,7 +503,7 @@   defaultResult' mk = do     (f, t0) <- inferHead hd     expandLast <- asksTC envExpandLast-    checkArguments expandLast (getRange hd) args t0 t $ \ rs vs t1 checkedTarget -> do+    checkArguments cmp expandLast (getRange hd) args t0 t $ \ st@(ACState rs vs _ t1 checkedTarget) -> do       let check = do            k <- mk            as <- allApplyElims vs@@ -481,7 +513,7 @@                 map Apply <$> ck               Nothing -> do                 return vs-      v <- unfoldInlined (f vs)+      v <- unfoldInlined =<< checkHeadConstraints f (st { acElims = vs })       coerce' cmp checkedTarget v t1 t  -- Issue #3019 and #4170: Don't insert trailing implicits when checking arguments to existing@@ -520,28 +552,29 @@ --   type @t0'@ (which should be a subtype of @t1@) and any constraints @cs@ --   that have to be solved for everything to be well-formed. -checkArgumentsE :: ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Maybe Type ->-                   ExceptT (MaybeRanges, Elims, [NamedArg A.Expr], Type) TCM (MaybeRanges, Elims, Type, CheckedTarget)+checkArgumentsE :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Maybe Type ->+                   ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget) checkArgumentsE = checkArgumentsE' NotCheckedTarget  checkArgumentsE'   :: CheckedTarget     -- ^ Have we already checked the target?+  -> Comparison        -- ^ Comparison to use if checking target type   -> ExpandHidden      -- ^ Insert trailing hidden arguments?   -> Range             -- ^ Range of the function.   -> [NamedArg A.Expr] -- ^ Arguments.   -> Type              -- ^ Type of the function.   -> Maybe Type        -- ^ Type of the application.-  -> ExceptT (MaybeRanges, Elims, [NamedArg A.Expr], Type) TCM (MaybeRanges, Elims, Type, CheckedTarget)+  -> ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)  -- Case: no arguments, do not insert trailing hidden arguments: We are done.-checkArgumentsE' chk exh _ [] t0 _ | isDontExpandLast exh = return ([], [], t0, chk)+checkArgumentsE' chk cmp exh _ [] t0 _ | isDontExpandLast exh = return $ ACState [] [] [] t0 chk  -- Case: no arguments, but need to insert trailing hiddens.-checkArgumentsE' chk _ExpandLast r [] t0 mt1 =+checkArgumentsE' chk cmp _ExpandLast r [] t0 mt1 =     traceCallE (CheckArguments r [] t0 mt1) $ lift $ do       mt1' <- traverse (unEl <.> reduce) mt1       (us, t) <- implicitArgs (-1) (expand mt1') t0-      return (replicate (length us) Nothing, map Apply us, t, chk)+      return $ ACState (replicate (length us) Nothing) (map Apply us) (replicate (length us) Nothing) t chk     where       expand (Just (Pi dom _)) Hidden     = not (hidden dom)       expand _                 Hidden     = True@@ -550,7 +583,7 @@       expand _                 NotHidden  = False  -- Case: argument given.-checkArgumentsE' chk exh r args0@(arg@(Arg info e) : args) t0 mt1 =+checkArgumentsE' chk cmp exh r args0@(arg@(Arg info e) : args) t0 mt1 =     traceCallE (CheckArguments r args0 t0 mt1) $ do       lift $ reportSDoc "tc.term.args" 30 $ sep         [ "checkArgumentsE"@@ -587,7 +620,7 @@       t <- lift $ forcePiUsingInjectivity t        -- We are done inserting implicit args.  Now, try to check @arg@.-      ifBlocked t (\ m t -> throwError (replicate (length us) Nothing, us, args0, t)) $ \ _ t0' -> do+      ifBlocked t (\ m t -> throwError $ ACState (replicate (length us) Nothing) us (replicate (length us) Nothing) t args0) $ \ _ t0' -> do          -- What can go wrong? @@ -623,7 +656,7 @@                   vis = all visible (telToList tel)                   isRigid t | PathType{} <- viewPath t = return False -- Path is not rigid!                   isRigid (El _ (Pi dom _)) = return $ visible dom-                  isRigid (El _ (Def d _))  = theDef <$> getConstInfo d >>= return . \ case+                  isRigid (El _ (Def d _))  = getConstInfo d <&> theDef <&> \ case                     Axiom{}                   -> True                     DataOrRecSig{}            -> True                     AbstractDefn{}            -> True@@ -633,6 +666,7 @@                     Constructor{}             -> __IMPOSSIBLE__                     GeneralizableVar{}        -> __IMPOSSIBLE__                     Primitive{}               -> False+                    PrimitiveSort{}           -> False                   isRigid _           = return False               rigid <- isRigid tgt               -- Andreas, 2019-03-28, issue #3248:@@ -646,13 +680,13 @@                  | not vis   -> return chk    -- and only visible arguments                  | isSizeLt  -> return chk    -- Issue #3248, not Size<                  | otherwise -> do-                  let tgt1 = applySubst (strengthenS __IMPOSSIBLE__ $ size tel) tgt+                  let tgt1 = applySubst (strengthenS impossible $ size tel) tgt                   reportSDoc "tc.term.args.target" 30 $ vcat                     [ "Checking target types first"                     , nest 2 $ "inferred =" <+> prettyTCM tgt1                     , nest 2 $ "expected =" <+> prettyTCM t1 ]                   traceCall (CheckTargetType (fuseRange r args0) tgt1 t1) $-                    CheckedTarget <$> ifNoConstraints_ (leqType tgt1 t1)+                    CheckedTarget <$> ifNoConstraints_ (compareType cmp tgt1 t1)                                         (return Nothing) (return . Just)              _ -> return chk@@ -677,11 +711,16 @@                  -- Thus, the following naive use violates some invariant.                  -- if not $ isBinderUsed b                  -- then postponeTypeCheckingProblem (CheckExpr (namedThing e) a) (return True) else-                  let e' = e { nameOf = maybe dname Just (nameOf e) }+                  let e' = e { nameOf = (nameOf e) <|> dname }                   checkNamedArg (Arg info' e') a++                let c | IsLock == getLock info' = Just $ Abs "t" (CheckLockedVars (Var 0 []) (raise 1 t0') (raise 1 $ Arg info' u) (raise 1 a))+                      | otherwise = Nothing+                lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info')+                lift $ reportSDoc "tc.term.lock" 40 $ addContext (defaultDom $ t0') $ maybe (text "nothing") prettyTCM (absBody <$> c)                 -- save relevance info' from domain in argument-                addCheckedArgs us (getRange e) (Apply $ Arg info' u) $-                  checkArgumentsE' chk' exh (fuseRange r e) args (absApp b u) mt1+                addCheckedArgs us (getRange e) (Apply $ Arg info' u) c $+                  checkArgumentsE' chk' cmp exh (fuseRange r e) args (absApp b u) mt1             | otherwise -> do                 reportSDoc "error" 10 $ nest 2 $ vcat                   [ text $ "info      = " ++ show info@@ -694,59 +733,65 @@             | visible info             , PathType s _ _ bA x y <- viewPath t0' -> do                 lift $ reportSDoc "tc.term.args" 30 $ text $ show bA-                u <- lift $ checkExpr (namedThing e) =<< elInf primInterval-                addCheckedArgs us (getRange e) (IApply (unArg x) (unArg y) u) $-                  checkArgumentsE exh (fuseRange r e) args (El s $ unArg bA `apply` [argN u]) mt1+                u <- lift $ checkExpr (namedThing e) =<< primIntervalType+                addCheckedArgs us (getRange e) (IApply (unArg x) (unArg y) u) Nothing $+                  checkArgumentsE cmp exh (fuseRange r e) args (El s $ unArg bA `apply` [argN u]) mt1           _ -> shouldBePi   where-    addCheckedArgs us r u rec = do-        (rs, vs, t, chk) <- rec+    -- Andrea: Here one would add constraints too.+    addCheckedArgs us r u c rec = do+        st@ACState{acRanges = rs, acElims = vs} <- rec         let rs' = replicate (length us) Nothing ++ Just r : rs-        return (rs', us ++ u : vs, t, chk)-      `catchError` \ (rs, vs, es, t) -> do+            cs' = replicate (length us) Nothing ++ c : acConstraints st+        return $ st { acRanges = rs', acElims = us ++ u : vs, acConstraints = cs' }+      `catchError` \ st@ACState{acRanges = rs, acElims = vs} -> do           let rs' = replicate (length us) Nothing ++ Just r : rs-          throwError (rs', us ++ u : vs, es, t)+              cs' = replicate (length us) Nothing ++ c : acConstraints st+          throwError $ st { acRanges = rs', acElims = us ++ u : vs, acConstraints = cs' }  -- | Check that a list of arguments fits a telescope. --   Inserts hidden arguments as necessary. --   Returns the type-checked arguments and the remaining telescope. checkArguments_-  :: ExpandHidden         -- ^ Eagerly insert trailing hidden arguments?+  :: Comparison           -- ^ Comparison for target+  -> ExpandHidden         -- ^ Eagerly insert trailing hidden arguments?   -> Range                -- ^ Range of application.   -> [NamedArg A.Expr]    -- ^ Arguments to check.   -> Telescope            -- ^ Telescope to check arguments against.   -> TCM (Elims, Telescope)      -- ^ Checked arguments and remaining telescope if successful.-checkArguments_ exh r args tel = postponeInstanceConstraints $ do+checkArguments_ cmp exh r args tel = postponeInstanceConstraints $ do     z <- runExceptT $-      checkArgumentsE exh r args (telePi tel __DUMMY_TYPE__) Nothing+      checkArgumentsE cmp exh r args (telePi tel __DUMMY_TYPE__) Nothing     case z of-      Right (_, args, t, _) -> do+      Right (ACState _ args cs t _) | all isNothing cs -> do         let TelV tel' _ = telView' t         return (args, tel')+                                    | otherwise -> do+        typeError $ GenericError $ "Head constraints are not (yet) supported in this position."       Left _ -> __IMPOSSIBLE__  -- type cannot be blocked as it is generated by telePi --- | @checkArguments exph r args t0 t k@ tries @checkArgumentsE exph args t0 t@.+-- | @checkArguments cmp exph r args t0 t k@ tries @checkArgumentsE exph args t0 t@. -- If it succeeds, it continues @k@ with the returned results.  If it fails, -- it registers a postponed typechecking problem and returns the resulting new -- meta variable. -- -- Checks @e := ((_ : t0) args) : t@. checkArguments ::-  ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-  (MaybeRanges -> Elims -> Type -> CheckedTarget -> TCM Term) -> TCM Term-checkArguments exph r args t0 t k = postponeInstanceConstraints $ do-  z <- runExceptT $ checkArgumentsE exph r args t0 (Just t)+  Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->+  (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term+checkArguments cmp exph r args t0 t k = postponeInstanceConstraints $ do+  z <- runExceptT $ checkArgumentsE cmp exph r args t0 (Just t)   case z of-    Right (rs, vs, t1, pid) -> k rs vs t1 pid+    Right st -> k st       -- vs = evaluated args       -- t1 = remaining type (needs to be subtype of t)-    Left problem -> postponeArgs problem exph r args t k+    Left problem -> postponeArgs problem cmp exph r args t k       -- if unsuccessful, postpone checking until t0 unblocks -postponeArgs :: (MaybeRanges, Elims, [NamedArg A.Expr], Type) -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type ->-                (MaybeRanges -> Elims -> Type -> CheckedTarget -> TCM Term) -> TCM Term-postponeArgs (rs, us, es, t0) exph r args t k = do+postponeArgs :: (ArgsCheckState [NamedArg A.Expr]) -> Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type ->+                (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term+postponeArgs (ACState rs us cs t0 es) cmp exph r args t k = do   reportSDoc "tc.term.expr.args" 80 $     sep [ "postponed checking arguments"         , nest 4 $ prettyList (map (prettyA . namedThing . unArg) args)@@ -756,7 +801,7 @@         , nest 2 $ "checked" <+> prettyList (map prettyTCM us)         , nest 2 $ "remaining" <+> sep [ prettyList (map (prettyA . namedThing . unArg) es)                                             , nest 2 $ ":" <+> prettyTCM t0 ] ]-  postponeTypeCheckingProblem_ (CheckArgs exph r es t0 t $ \ rs' vs t pid -> k (rs ++ rs') (us ++ vs) t pid)+  postponeTypeCheckingProblem_ (CheckArgs cmp exph r es t0 t $ \ (ACState rs' vs cs' t pid) -> k $ ACState (rs ++ rs') (us ++ vs) (cs ++ cs') t pid)  ----------------------------------------------------------------------------- -- * Constructors@@ -775,10 +820,15 @@       , "c    =" <+> prettyTCM c       , "args =" <+> prettyTCM args     ] ]++  cdef  <- getConInfo c++  checkModality (conName c) cdef+   let paramsGiven = checkForParams args   if paramsGiven then fallback else do     reportSDoc "tc.term.con" 50 $ "checkConstructorApplication: no parameters explicitly supplied, continuing..."-    cdef  <- getConInfo c+     let Constructor{conData = d, conPars = npars} = theDef cdef     reportSDoc "tc.term.con" 50 $ nest 2 $ "d    =" <+> prettyTCM d     -- Issue 661: t maybe an evaluated form of d .., so we evaluate d@@ -797,7 +847,7 @@          -- Since we get the constructor type ctype from d but the parameters          -- from t = Def d' vs, we drop the additional parameters.          npars' <- getNumberOfParameters d'-         caseMaybe (sequenceA $ List2 (Just npars, npars')) fallback $ \ (List2 (n, n')) -> do+         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'            when (n > n')  -- preprocessor does not like ', so put on next line@@ -817,11 +867,12 @@                args' = dropArgs pnames args            -- check the non-parameter arguments            expandLast <- asksTC envExpandLast-           checkArguments expandLast (getRange c) args' ctype' t $ \ rs es t' targetCheck -> do+           checkArguments cmp expandLast (getRange c) args' ctype' t $ \ st@(ACState _ _ _ t' targetCheck) -> do              reportSDoc "tc.term.con" 20 $ nest 2 $ vcat                [ text "es     =" <+> prettyTCM es                , text "t'     =" <+> prettyTCM t' ]-             coerce' cmp targetCheck (Con c ConOCon es) t' t+             v <- checkHeadConstraints (Con c ConOCon) st+             coerce' cmp targetCheck v t' t       _ -> do         reportSDoc "tc.term.con" 50 $ nest 2 $ "we are not at a datatype, falling back"         fallback@@ -834,10 +885,10 @@     --     -- Andreas, 2012-04-18: if all inital args are underscores, ignore them     checkForParams args =-      let (hargs, rest) = span (not . visible) args+      let (hargs, rest) = break visible args           notUnderscore A.Underscore{} = False           notUnderscore _              = True-      in  any notUnderscore $ map (unScope . namedArg) hargs+      in  any (notUnderscore . unScope . namedArg) hargs      -- Drop the constructor arguments that correspond to parameters.     dropArgs [] args                = args@@ -860,62 +911,69 @@         dropPar _ [] = Nothing  -- | Returns an unblocking action in case of failure.-disambiguateConstructor :: NonEmpty QName -> Type -> TCM (Either (TCM Bool) ConHead)+disambiguateConstructor :: List1 QName -> Type -> TCM (Either Blocker ConHead) disambiguateConstructor cs0 t = do   reportSLn "tc.check.term.con" 40 $ "Ambiguous constructor: " ++ prettyShow cs0    -- Get the datatypes of the various constructors   let getData Constructor{conData = d} = d       getData _                        = __IMPOSSIBLE__-  reportSLn "tc.check.term.con" 40 $ "  ranges before: " ++ show (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).   -- See issue 279.   -- Andreas, 2017-08-13, issue #2686: ignore abstract constructors-  (cs, cons)  <- unzip . snd . partitionEithers <$> do-     forM (NonEmpty.toList cs0) $ \ c -> mapRight (c,) <$> getConForm c-  reportSLn "tc.check.term.con" 40 $ "  reduced: " ++ prettyShow cons-  case cons of-    []    -> typeError $ AbstractConstructorNotInScope $ NonEmpty.head cs0-    [con] -> do-      let c = setConName (headWithDefault __IMPOSSIBLE__ cs) con+  ccons  <- List1.rights <$> do+     forM cs0 $ \ c -> mapRight (c,) <$> getConForm c+  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-      storeDisambiguatedName $ conName c+      storeDisambiguatedConstructor (conInductive c) (conName c)       return (Right c)-    _   -> do-      dcs <- zipWithM (\ c con -> (, setConName c con) . getData . theDef <$> getConInfo con) cs cons+    (c0,_):_   -> do+      dcs <- forM ccons $ \ (c, con) -> (, setConName c con) . getData . theDef <$> getConInfo con       -- Type error-      let badCon t = typeError $ flip DoesNotConstructAnElementOf t $-            headWithDefault __IMPOSSIBLE__ cs+      let badCon t = typeError $ DoesNotConstructAnElementOf c0 t       -- Lets look at the target type at this point-      let getCon :: TCM (Maybe ConHead)-          getCon = do-            TelV tel t1 <- telViewPath t-            addContext tel $ do-             reportSDoc "tc.check.term.con" 40 $ nest 2 $-               "target type: " <+> prettyTCM t1-             ifBlocked t1 (\ m t -> return Nothing) $ \ _ t' ->-               caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ d ->-                 case [ c | (d', c) <- dcs, d == d' ] of-                   [c] -> do-                     reportSLn "tc.check.term.con" 40 $ "  decided on: " ++ prettyShow c-                     storeDisambiguatedName $ conName c-                     return $ Just c-                   []  -> badCon $ t' $> Def d []-                   cs  -> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d $ map conName cs-      getCon >>= \ case-        Nothing -> return $ Left $ isJust <$> getCon-        Just c  -> return $ Right c+      TelV tel t1 <- telViewPath t+      addContext tel $ do+       reportSDoc "tc.check.term.con" 40 $ nest 2 $+         "target type: " <+> prettyTCM t1+       ifBlocked t1 (\ b t -> return $ Left b) $ \ _ t' ->+         caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ d ->+           case [ c | (d', c) <- dcs, d == d' ] of+             [c] -> do+               reportSLn "tc.check.term.con" 40 $ "  decided on: " ++ prettyShow c+               storeDisambiguatedConstructor (conInductive c) (conName c)+               return $ Right c+             []  -> badCon $ t' $> Def d []+             c:cs-> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d $+                      fmap conName $ c :| cs  --------------------------------------------------------------------------- -- * Projections --------------------------------------------------------------------------- +checkUnambiguousProjectionApplication :: Comparison -> A.Expr -> Type -> QName -> ProjOrigin -> A.Expr -> [NamedArg A.Expr] -> TCM Term+checkUnambiguousProjectionApplication cmp e t x o hd args =+  -- Andreas, 2021-02-19, issue #3289+  -- If a postfix projection was moved to the head by appView,+  -- we have to patch the first argument with the correct hiding info.+  case (o, args) of+    (ProjPostfix, arg : rest) -> do+      pr <- fromMaybe __IMPOSSIBLE__ <$> isProjection x+      let ai = projArgInfo pr+      checkHeadApplication cmp e t hd (setArgInfo ai arg : rest)+    _ -> checkHeadApplication cmp e t hd args+ -- | Inferring the type of an overloaded projection application. --   See 'inferOrCheckProjApp'. -inferProjApp :: A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> TCM (Term, Type)+inferProjApp :: A.Expr -> ProjOrigin -> List1 QName -> A.Args -> TCM (Term, Type) inferProjApp e o ds args0 = do   (v, t, _) <- inferOrCheckProjApp e o ds args0 Nothing   return (v, t)@@ -923,7 +981,7 @@ -- | Checking the type of an overloaded projection application. --   See 'inferOrCheckProjApp'. -checkProjApp  :: Comparison -> A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> Type -> TCM Term+checkProjApp  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Args -> Type -> TCM Term checkProjApp cmp e o ds args0 t = do   (v, ti, targetCheck) <- inferOrCheckProjApp e o ds args0 (Just (cmp, t))   coerce' cmp targetCheck v ti t@@ -931,9 +989,9 @@ -- | Checking the type of an overloaded projection application. --   See 'inferOrCheckProjAppToKnownPrincipalArg'. -checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> Type -> Int -> Term -> Type -> TCM Term-checkProjAppToKnownPrincipalArg cmp e o ds args0 t k v0 pt = do-  (v, ti, targetCheck) <- inferOrCheckProjAppToKnownPrincipalArg e o ds args0 (Just (cmp, t)) k v0 pt+checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term+checkProjAppToKnownPrincipalArg cmp e o ds args0 t k v0 pt patm = do+  (v, ti, targetCheck) <- inferOrCheckProjAppToKnownPrincipalArg e o ds args0 (Just (cmp, t)) k v0 pt (Just patm)   coerce' cmp targetCheck v ti t  -- | Inferring or Checking an overloaded projection application.@@ -946,7 +1004,7 @@      -- ^ The whole expression which constitutes the application.   -> ProjOrigin      -- ^ The origin of the projection involved in this projection application.-  -> NonEmpty QName+  -> List1 QName      -- ^ The projection name (potentially ambiguous).   -> A.Args      -- ^ The arguments to the projection.@@ -967,9 +1025,9 @@       -- Postpone the whole type checking problem       -- if type of principal argument (or the type where we get it from)       -- is blocked by meta m.-      postpone m = do+      postpone b = do         tc <- caseMaybe mt newTypeMeta_ (return . snd)-        v <- postponeTypeCheckingProblem (CheckExpr cmp e tc) $ isInstantiatedMeta m+        v <- postponeTypeCheckingProblem (CheckExpr cmp e tc) b         return (v, tc, NotCheckedTarget)    -- The following cases need to be considered:@@ -994,10 +1052,10 @@       caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds) $ \ (_q, _pars, defn) -> do       case defn of         Record { recFields = fs } -> do-          case forMaybe fs $ \ f -> List.find (unDom f ==) (NonEmpty.toList ds) of+          case forMaybe fs $ \ f -> Fold.find (unDom f ==) ds of             [] -> refuseProjNoMatching ds             [d] -> do-              storeDisambiguatedName d+              storeDisambiguatedProjection d               -- checkHeadApplication will check the target type               (, t, CheckedTarget Nothing) <$>                 checkHeadApplication cmp e t (A.Proj o $ unambiguous d) args@@ -1011,23 +1069,47 @@         [ "  principal arg " <+> prettyTCM arg         , "  has type "      <+> prettyTCM ta         ]-      inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta+      inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta Nothing  -- | Same arguments 'inferOrCheckProjApp' above but also gets the position, --   value and type of the principal argument.-inferOrCheckProjAppToKnownPrincipalArg ::-  A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> Maybe (Comparison, Type) ->-  Int -> Term -> Type -> TCM (Term, Type, CheckedTarget)-inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta = do+inferOrCheckProjAppToKnownPrincipalArg+  :: A.Expr+     -- ^ The whole expression which constitutes the application.+  -> ProjOrigin+     -- ^ The origin of the projection involved in this projection application.+  -> List1 QName+     -- ^ The projection name (potentially ambiguous).+  -> A.Args+     -- ^ The arguments to the projection.+  -> Maybe (Comparison, Type)+     -- ^ The expected type of the expression (if 'Nothing', infer it).+  -> Int+     -- ^ The position of the principal argument.+  -> Term+     -- ^ The value of the principal argument.+  -> Type+     -- ^ The type of the principal argument.+  -> Maybe PrincipalArgTypeMetas+     -- ^ The metas previously created for the principal argument's type, when+     --   picking up a postponed problem. 'Nothing', otherwise.+  -> TCM (Term, Type, CheckedTarget)+     -- ^ The type-checked expression and its type (if successful).+inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta mpatm = do   let cmp = caseMaybe mt CmpEq fst-      postpone m = do+      postpone b patm = do         tc <- caseMaybe mt newTypeMeta_ (return . snd)-        v <- postponeTypeCheckingProblem (CheckProjAppToKnownPrincipalArg cmp e o ds args tc k v0 ta) $ isInstantiatedMeta m+        v <- postponeTypeCheckingProblem (CheckProjAppToKnownPrincipalArg cmp e o ds args tc k v0 ta patm) b         return (v, tc, NotCheckedTarget)   -- ta should be a record type (after introducing the hidden args in v0)-  (vargs, ta) <- implicitArgs (-1) (not . visible) ta+  patm@(PrincipalArgTypeMetas vargs ta) <- case mpatm of+    -- keep using the previously created metas, when picking up a postponed+    -- problem - see #4924+    Just patm -> return patm+    -- create fresh metas+    Nothing -> uncurry PrincipalArgTypeMetas <$> implicitArgs (-1) (not . visible) ta   let v = v0 `apply` vargs-  ifBlocked ta (\ m _ -> postpone m) {-else-} $ \ _ ta -> do+  ifBlocked ta (\ m _ -> postpone m patm) {-else-} $ \ _ ta -> do   caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds) $ \ (q, _pars0, _) -> do        -- try to project it with all of the possible projections@@ -1041,8 +1123,8 @@             def <- lift $ getConstInfo d             let isP = isProjection_ $ theDef def             reportSDoc "tc.proj.amb" 40 $ vcat $-              [ text $ "  isProjection = " ++ caseMaybe isP "no" (const "yes")-              ] ++ caseMaybe isP [] (\ Projection{ projProper = proper, projOrig = orig } ->+              text ( "  isProjection = " ++ caseMaybe isP "no" (const "yes")+                   ) : caseMaybe isP [] (\ Projection{ projProper = proper, projOrig = orig } ->               [ text $ "  proper       = " ++ show proper               , text $ "  orig         = " ++ prettyShow orig               ])@@ -1087,7 +1169,7 @@             guard =<< do isNothing <$> do lift $ checkModality' d def             return (orig, (d, (pars, (dom, u, tb)))) -      cands <- groupOn fst . catMaybes <$> mapM (runMaybeT . try) (NonEmpty.toList ds)+      cands <- groupOn fst . List1.catMaybes <$> mapM (runMaybeT . try) ds       case cands of         [] -> refuseProjNoMatching ds         [[]] -> refuseProjNoMatching ds@@ -1097,7 +1179,7 @@         -- the term u = d v         -- the type tb is the type of this application         [ (_orig, (d, (pars, (_dom,u,tb)))) : _ ] -> do-          storeDisambiguatedName d+          storeDisambiguatedProjection d            -- Check parameters           tfull <- typeOfConst d@@ -1106,31 +1188,123 @@           -- Check remaining arguments           let r     = getRange e               args' = drop (k + 1) args-          z <- runExceptT $ checkArgumentsE ExpandLast r args' tb (snd <$> mt)+          z <- runExceptT $ checkArgumentsE cmp ExpandLast r args' tb (snd <$> mt)           case z of-            Right (rs, us, trest, targetCheck) -> return (u `applyE` us, trest, targetCheck)+            Right st@(ACState _ _ _ trest targetCheck) -> do+              v <- checkHeadConstraints (u `applyE`) st+              return (v, trest, targetCheck)             Left problem -> do               -- In the inference case:               -- To create a postponed type checking problem,               -- we do not use typeDontCare, but create a meta.               tc <- caseMaybe mt newTypeMeta_ (return . snd)-              v  <- postponeArgs problem ExpandLast r args' tc $ \ rs us trest targetCheck ->-                      coerce' cmp targetCheck (u `applyE` us) trest tc+              v  <- postponeArgs problem cmp ExpandLast r args' tc $ \ st@(ACState _ _ _ trest targetCheck) -> do+                      v <- checkHeadConstraints (u `applyE`) st+                      coerce' cmp targetCheck v trest tc                return (v, tc, NotCheckedTarget) -refuseProj :: NonEmpty QName -> String -> TCM a+refuseProj :: List1 QName -> String -> TCM a refuseProj ds reason = typeError $ GenericError $         "Cannot resolve overloaded projection "-        ++ prettyShow (A.nameConcrete $ A.qnameName $ NonEmpty.head ds)+        ++ prettyShow (A.nameConcrete $ A.qnameName $ List1.head ds)         ++ " because " ++ reason -refuseProjNotApplied, refuseProjNoMatching, refuseProjNotRecordType :: NonEmpty QName -> TCM a+refuseProjNotApplied, refuseProjNoMatching, refuseProjNotRecordType :: List1 QName -> TCM a refuseProjNotApplied    ds = refuseProj ds "it is not applied to a visible argument" refuseProjNoMatching    ds = refuseProj ds "no matching candidate found" refuseProjNotRecordType ds = refuseProj ds "principal argument is not of record type"  -----------------------------------------------------------------------------+-- * Sorts+-----------------------------------------------------------------------------++checkSet+  :: Comparison -> A.Expr -> Type+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkSet = checkSetOrProp Type++checkProp+  :: Comparison -> A.Expr -> Type+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkProp cmp e t q s args = do+  unlessM isPropEnabled $ typeError NeedOptionProp+  checkSetOrProp Prop cmp e t q s args++checkSSet+  :: Comparison -> A.Expr -> Type+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkSSet cmp e t q s args = do+  unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel+  checkLeveledSort SSet SSet cmp e t q s args++checkSetOrProp+  :: (Level -> Sort) -> Comparison -> A.Expr -> Type+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkSetOrProp mkSort cmp e t q suffix args = do+  checkLeveledSort mkSort Type cmp e t q suffix args++checkLeveledSort+  :: (Level -> Sort) -> (Level -> Sort) -> Comparison -> A.Expr -> Type+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkLeveledSort mkSort mkSortOfSort cmp e t q suffix args = do+  (v, t0) <- inferLeveledSort mkSort mkSortOfSort e q suffix args+  coerce cmp v t0 t++inferSet :: A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferSet = inferSetOrProp Type++inferProp :: A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferProp e q s args = do+  unlessM isPropEnabled $ typeError NeedOptionProp+  inferSetOrProp Prop e q s args++inferSSet :: A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferSSet e q s args = do+  unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel+  inferLeveledSort SSet SSet e q s args++inferSetOrProp+  :: (Level -> Sort) -> A.Expr+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferSetOrProp mkSort e q suffix args = inferLeveledSort mkSort Type e q suffix args++inferLeveledSort+  :: (Level -> Sort) -> (Level -> Sort) -> A.Expr+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferLeveledSort mkSort mkSortOfSort e q suffix args = case args of+  [] -> do+    let n = case suffix of+              NoSuffix -> 0+              Suffix n -> n+    return (Sort (mkSort $ ClosedLevel n) , sort (mkSortOfSort $ ClosedLevel $ n + 1))+  [arg] -> do+    unless (visible arg) $ typeError $ WrongHidingInApplication $ sort $ mkSort $ ClosedLevel 0+    unlessM hasUniversePolymorphism $ genericError+      "Use --universe-polymorphism to enable level arguments to Set"+    l <- applyRelevanceToContext NonStrict $ checkLevel arg+    return (Sort $ mkSort l , sort (mkSortOfSort $ levelSuc l))+  arg : _ -> typeError . GenericDocError =<< fsep+    [ prettyTCM q , "cannot be applied to more than one argument" ]++checkSetOmega :: Comparison -> A.Expr -> Type -> QName -> IsFibrant -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkSetOmega cmp e t q f s args = do+  (v, t0) <- inferSetOmega e q f s args+  coerce cmp v t0 t++inferSetOmega :: A.Expr -> QName -> IsFibrant -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferSetOmega e q f suffix args = do+  when (f == IsStrict) $+    unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel+  let n = case suffix of+            NoSuffix -> 0+            Suffix n -> n+  case args of+    [] -> return (Sort (Inf f n) , sort (Inf f $ 1 + n))+    arg : _ -> typeError . GenericDocError =<< fsep+        [ prettyTCM q , "cannot be applied to an argument" ]++----------------------------------------------------------------------------- -- * Coinduction ----------------------------------------------------------------------------- @@ -1240,7 +1414,7 @@       iz <- Arg defaultArgInfo <$> intervalUnview IZero       let lz = unArg l `apply` [iz]           az = unArg a `apply` [iz]-      ty <- elInf $ primPartial <#> (pure $ unArg l `apply` [iz]) <@> (pure $ unArg phi) <@> (pure $ unArg a `apply` [iz])+      ty <- el's (pure (unArg l `apply` [iz])) $ primPartial <#> pure (unArg l `apply` [iz]) <@> pure (unArg phi) <@> pure (unArg a `apply` [iz])       bAz <- el' (pure $ lz) (pure $ az)       a0 <- blockArg bAz (rs !!! 4) a0 $ do         equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))@@ -1261,7 +1435,7 @@       -- iz = i0       iz <- Arg defaultArgInfo <$> intervalUnview IZero       -- ty = Partial φ A-      ty <- elInf $ primPartial <#> (pure $ unArg l) <@> (pure $ unArg phi) <@> (pure $ unArg a)+      ty <- el's (pure (unArg l)) $ primPartial <#> pure (unArg l) <@> pure (unArg phi) <@> pure (unArg a)       -- (λ _ → a) = u i0 : ty       bA <- el' (pure $ unArg l) (pure $ unArg a)       a0 <- blockArg bA (rs !!! 4) a0 $ do@@ -1287,7 +1461,7 @@       -- ty = (i : I) -> Set (l i)       ty <- runNamesT [] $ do         l <- open $ unArg l-        nPi' "i" (elInf $ cl primInterval) $ \ i -> (sort . tmSort <$> (l <@> i))+        nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (l <@> i))       a <- blockArg ty (rs !!! 1) a $ do         equalTermOnFace (unArg phi) ty           (unArg a)@@ -1311,7 +1485,7 @@           pathAbs iv (NoAbs (stringToArgName "_") (unArg x))       p <- blockArg ty (rs !!! 5) p $ do         equalTermOnFace (unArg phi) ty (unArg p) const_x   -- G, phi |- p = \ i . x-      return $ init args ++ [p]+      return $ initWithDefault __IMPOSSIBLE__ args ++ [p]       -- phi <- reduce phi       -- forallFaceMaps (unArg phi) $ \ alpha -> do       --   iv@(PathType s _ l a x y) <- idViewAsPath (applySubst alpha t1)@@ -1370,7 +1544,7 @@             glam iinfo "o" $ \ o -> f o <@> (t <..> o)       ty <- runNamesT [] $ do             [lb, phi, bA] <- mapM (open . unArg) [lb, phi, bA]-            elInf $ cl primPartialP <#> lb <@> phi <@> (glam iinfo "o" $ \ _ -> bA)+            el's lb $ cl primPartialP <#> lb <@> phi <@> glam iinfo "o" (\ _ -> bA)       let a' = Lam iinfo (NoAbs "o" $ unArg a)       ta <- el' (pure $ unArg la) (pure $ unArg bA)       a <- blockArg ta (rs !!! 7) a $ equalTerm ty a' v@@ -1392,7 +1566,7 @@       let iinfo = setRelevance Irrelevant defaultArgInfo       v <- runNamesT [] $ do             [la, phi, bT, bA, t] <- mapM (open . unArg) [la, phi, bT, bA, t]-            let f o = cl primTrans <#> (lam "i" $ const la) <@> (lam "i" $ \ i -> bT <@> (cl primINeg <@> i) <..> o) <@> cl primIZero+            let f o = cl primTrans <#> lam "i" (const la) <@> lam "i" (\ i -> bT <@> (cl primINeg <@> i) <..> o) <@> cl primIZero             glam iinfo "o" $ \ o -> f o <@> (t <..> o)       ty <- runNamesT [] $ do             [la, phi, bT] <- mapM (open . unArg) [la, phi, bT]

src/full/Agda/TypeChecking/Rules/Application.hs-boot view

@@ -9,14 +9,14 @@ import Agda.Syntax.Position import Agda.TypeChecking.Monad.Base -checkArguments :: ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-                  ([Maybe Range] -> Elims -> Type -> CheckedTarget -> TCM Term) -> TCM Term+checkArguments :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->+                  (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term -checkArguments_ :: ExpandHidden -> Range -> [NamedArg A.Expr] -> Telescope ->+checkArguments_ :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Telescope ->                    TCM (Elims, Telescope)  checkApplication :: Comparison -> A.Expr -> A.Args -> A.Expr -> Type -> TCM Term  inferApplication :: ExpandHidden -> A.Expr -> A.Args -> A.Expr -> TCM (Term, Type) -checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> Type -> Int -> Term -> Type -> TCM Term+checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term

src/full/Agda/TypeChecking/Rules/Builtin.hs view

@@ -9,10 +9,13 @@   , bindUntypedBuiltin   ) where +import Prelude hiding (null)+ import Control.Monad+import Control.Monad.Except+ import Data.List (find, sortBy) import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.Function (on)  import qualified Agda.Syntax.Abstract as A@@ -22,8 +25,6 @@ import Agda.Syntax.Scope.Base  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.SizedTypes ( builtinSizeHook )  import qualified Agda.TypeChecking.CompiledClause as CC import Agda.TypeChecking.Conversion@@ -32,6 +33,7 @@ import Agda.TypeChecking.Functions import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Names+import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Reduce@@ -43,7 +45,6 @@ import {-# SOURCE #-} Agda.TypeChecking.Rules.Builtin.Coinduction import {-# SOURCE #-} Agda.TypeChecking.Rewriting -import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe@@ -61,7 +62,7 @@ builtinPostulate = BuiltinPostulate Relevant  builtinPostulateC :: TCM Type -> BuiltinDescriptor-builtinPostulateC m = BuiltinPostulate Relevant $ requireCubical >> m+builtinPostulateC m = BuiltinPostulate Relevant $ requireCubical "" >> m  findBuiltinInfo :: String -> Maybe BuiltinInfo findBuiltinInfo b = find ((b ==) . builtinName) coreBuiltins@@ -74,6 +75,7 @@   , (builtinArgInfo                          |-> BuiltinData tset [builtinArgArgInfo])   , (builtinBool                             |-> BuiltinData tset [builtinTrue, builtinFalse])   , (builtinNat                              |-> BuiltinData tset [builtinZero, builtinSuc])+  , (builtinMaybe                            |-> BuiltinData (tset --> tset) [builtinNothing, builtinJust])   , (builtinSigma                            |-> BuiltinData (runNamesT [] $                                                               hPi' "la" (el $ cl primLevel) $ \ a ->                                                               hPi' "lb" (el $ cl primLevel) $ \ b ->@@ -88,12 +90,12 @@                                                                    builtinAgdaLitQName, builtinAgdaLitMeta])   , (builtinAgdaPattern                      |-> BuiltinData tset [builtinAgdaPatVar, builtinAgdaPatCon, builtinAgdaPatDot,                                                                    builtinAgdaPatLit, builtinAgdaPatProj, builtinAgdaPatAbsurd])-  , (builtinAgdaPatVar                       |-> BuiltinDataCons (tstring --> tpat))+  , (builtinAgdaPatVar                       |-> BuiltinDataCons (tnat --> tpat))   , (builtinAgdaPatCon                       |-> BuiltinDataCons (tqname --> tlist (targ tpat) --> tpat))-  , (builtinAgdaPatDot                       |-> BuiltinDataCons tpat)+  , (builtinAgdaPatDot                       |-> BuiltinDataCons (tterm --> tpat))   , (builtinAgdaPatLit                       |-> BuiltinDataCons (tliteral --> tpat))   , (builtinAgdaPatProj                      |-> BuiltinDataCons (tqname --> tpat))-  , (builtinAgdaPatAbsurd                    |-> BuiltinDataCons tpat)+  , (builtinAgdaPatAbsurd                    |-> BuiltinDataCons (tnat --> tpat))   , (builtinLevel                            |-> builtinPostulate tset)   , (builtinWord64                           |-> builtinPostulate tset)   , (builtinInteger                          |-> BuiltinData tset [builtinIntegerPos, builtinIntegerNegSuc])@@ -106,46 +108,46 @@   , (builtinAgdaMeta                         |-> builtinPostulate tset)   , (builtinIO                               |-> builtinPostulate (tset --> tset))   , (builtinPath                             |-> BuiltinUnknown-                                                             (Just $ requireCubical >>-                                                             (hPi "a" (el primLevel) $+                                                             (Just $ requireCubical "" >>+                                                             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 (hPi "a" (el primLevel) $-                                                              nPi "A" (tinterval --> (return $ sort $ varSort 0)) $+                                                              nPi "A" (tinterval --> return (sort $ varSort 0)) $                                                               (El (varSort 1) <$> varM 0 <@> primIZero) -->                                                               (El (varSort 1) <$> varM 0 <@> primIOne) -->                                                               return (sort $ varSort 1)))-  , (builtinInterval                         |-> BuiltinData (requireCubical >> return (sort Inf)) [builtinIZero,builtinIOne])+  , (builtinInterval                         |-> BuiltinData (requireCubical "" >> (return $ ssort $ ClosedLevel 0)) [builtinIZero,builtinIOne])   , (builtinSub                              |-> builtinPostulateC (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a ->                                                                    nPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-                                                                   nPi' "φ" (elInf $ cl primInterval) $ \ phi ->-                                                                   elInf (cl primPartial <#> a <@> phi <@> bA) --> (return $ sort Inf)+                                                                   nPi' "φ" (cl tinterval) $ \ phi ->+                                                                   el's a (cl primPartial <#> a <@> phi <@> bA) --> (ssort . atomicLevel <$> a)                                                                   ))   , (builtinSubIn                            |-> builtinPostulateC (runNamesT [] $                                                                    hPi' "a" (el $ cl primLevel) $ \ a ->                                                                    hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-                                                                   hPi' "φ" (elInf $ cl primInterval) $ \ phi ->-                                                                   nPi' "x" (el' (Sort . tmSort <$> a) bA) $ \ x ->-                                                                   elInf $ cl primSub <#> a <@> bA <@> phi <@> (lam "o" $ \ _ -> x)))-  , (builtinIZero                            |-> BuiltinDataCons (elInf primInterval))-  , (builtinIOne                             |-> BuiltinDataCons (elInf primInterval))+                                                                   hPi' "φ" (elSSet $ cl primInterval) $ \ phi ->+                                                                   nPi' "x" (el' a bA) $ \ x ->+                                                                   el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (\ _ -> x)))+  , (builtinIZero                            |-> BuiltinDataCons tinterval)+  , (builtinIOne                             |-> BuiltinDataCons tinterval)   , (builtinPartial                          |-> BuiltinPrim "primPartial" (const $ return ()))   , (builtinPartialP                         |-> BuiltinPrim "primPartialP" (const $ return ()))-  , (builtinIsOne                            |-> builtinPostulateC (tinterval --> return (sort $ Inf)))-  , (builtinItIsOne                          |-> builtinPostulateC (elInf $ primIsOne <@> primIOne))+  , (builtinIsOne                            |-> builtinPostulateC (tinterval --> return (ssort $ ClosedLevel 0)))+  , (builtinItIsOne                          |-> builtinPostulateC (elSSet $ primIsOne <@> primIOne))   , (builtinIsOne1                           |-> builtinPostulateC (runNamesT [] $                                                                    nPi' "i" (cl tinterval) $ \ i ->                                                                    nPi' "j" (cl tinterval) $ \ j ->-                                                                   nPi' "i1" (elInf $ cl primIsOne <@> i) $ \ i1 ->-                                                                   (elInf $ cl primIsOne <@> (cl primIMax <@> i <@> j))))+                                                                   nPi' "i1" (elSSet $ cl primIsOne <@> i) $ \ i1 ->+                                                                   (elSSet $ cl primIsOne <@> (cl primIMax <@> i <@> j))))   , (builtinIsOne2                           |-> builtinPostulateC (runNamesT [] $                                                                    nPi' "i" (cl tinterval) $ \ i ->                                                                    nPi' "j" (cl tinterval) $ \ j ->-                                                                   nPi' "j1" (elInf $ cl primIsOne <@> j) $ \ j1 ->-                                                                   (elInf $ cl primIsOne <@> (cl primIMax <@> i <@> j))))+                                                                   nPi' "j1" (elSSet $ cl primIsOne <@> j) $ \ j1 ->+                                                                   (elSSet $ cl primIsOne <@> (cl primIMax <@> i <@> j))))   , (builtinIsOneEmpty                       |-> builtinPostulateC (runNamesT [] $                                                                    hPi' "l" (el $ cl primLevel) $ \ l ->                                                                    hPi' "A" (pPi' "o" (cl primIZero) $ \ _ ->@@ -165,7 +167,7 @@                                                            tinterval -->                                                            (El (varSort 3) <$> primPath <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0) -->                                                            (El (varSort 3) <$> primId <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0)))-  , (builtinEquiv                            |-> BuiltinUnknown (Just $ requireCubical >> runNamesT [] (+  , (builtinEquiv                            |-> BuiltinUnknown (Just $ requireCubical "" >> runNamesT [] (                                                                     hPi' "l" (el $ cl primLevel) $ \ a ->                                                                     hPi' "l'" (el $ cl primLevel) $ \ b ->                                                                     nPi' "A" (sort . tmSort <$> a) $ \bA ->@@ -173,7 +175,7 @@                                                                     ((sort . tmSort) <$> (cl primLevelMax <@> a <@> b))                                                                   ))                                                                    (const $ const $ return ()))-  , (builtinEquivFun                         |-> BuiltinUnknown (Just $ requireCubical >> runNamesT [] (+  , (builtinEquivFun                         |-> BuiltinUnknown (Just $ requireCubical "" >> runNamesT [] (                                                                  hPi' "l" (el $ cl primLevel) $ \ a ->                                                                  hPi' "l'" (el $ cl primLevel) $ \ b ->                                                                  hPi' "A" (sort . tmSort <$> a) $ \bA ->@@ -182,7 +184,7 @@                                                                  (el' a bA --> el' b bB)                                                                ))                                                                 (const $ const $ return ()))-  , (builtinEquivProof                       |-> BuiltinUnknown (Just $ requireCubical >> runNamesT [] (+  , (builtinEquivProof                       |-> BuiltinUnknown (Just $ requireCubical "" >> runNamesT [] (                                                                hPi' "l" (el $ cl primLevel) $ \ la ->                                                                hPi' "l'" (el $ cl primLevel) $ \ lb ->                                                                nPi' "A" (sort . tmSort <$> la) $ \ bA ->@@ -194,31 +196,34 @@                                                                     fiber = el' (cl primLevelMax <@> la <@> lb)                                                                                 (cl primSigma <#> la <#> lb                                                                                   <@> bA-                                                                                  <@> (lam "a" $ \ a ->+                                                                                  <@> lam "a" (\ a ->                                                                                          cl primPath <#> lb <#> bB <@> (f <@> a) <@> b))                                                                 nPi' "φ" (cl tinterval) $ \ phi ->-                                                                  (pPi' "o" phi $ \ o -> fiber) --> fiber+                                                                  pPi' "o" phi (\ o -> fiber) --> fiber                                                              ))                                                               (const $ const $ return ()))-  , (builtinTranspProof                       |-> BuiltinUnknown (Just $ requireCubical >> runNamesT [] (+  , (builtinTranspProof                       |-> BuiltinUnknown (Just $ requireCubical "" >> 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                                                                nPi' "φ" (cl tinterval) $ \ phi -> do                                                                nPi' "a" (pPi' "o" phi (\ _ -> el' la bA)) $ \ a -> do-                                                               let f = cl primTrans <#> (lam "i" $ \ _ -> la) <@> e <@> cl primIZero+                                                               let f = cl primTrans <#> lam "i" (\ _ -> la) <@> e <@> cl primIZero                                                                    z = ilam "o" $ \ o -> f <@> (a <@> o)-                                                               nPi' "b" (elInf (cl primSub <#> lb <@> bB <@> phi <@> z)) $ \ b' -> do+                                                               nPi' "b" (el's lb (cl primSub <#> lb <@> bB <@> phi <@> z)) $ \ b' -> do                                                                let b = cl primSubOut <#> lb <#> bB <#> phi <#> z <@> b'                                                                    fiber = el' la                                                                                (cl primSigma <#> la <#> lb                                                                                   <@> bA-                                                                                  <@> (lam "a" $ \ a ->+                                                                                  <@> lam "a" (\ a ->                                                                                          cl primPath <#> lb <#> bB <@> (f <@> a) <@> b))                                                                fiber                                                              ))                                                               (const $ const $ return ()))-  , (builtinAgdaSort                         |-> BuiltinData tset [builtinAgdaSortSet, builtinAgdaSortLit, builtinAgdaSortUnsupported])+  , (builtinAgdaSort                         |-> BuiltinData tset+                                                   [ builtinAgdaSortSet, builtinAgdaSortLit+                                                   , builtinAgdaSortProp, builtinAgdaSortPropLit+                                                   , builtinAgdaSortInf, builtinAgdaSortUnsupported])   , (builtinAgdaTerm                         |-> BuiltinData tset                                                    [ builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam                                                    , builtinAgdaTermDef, builtinAgdaTermCon@@ -241,6 +246,13 @@   , (builtinRelevance                        |-> BuiltinData tset [builtinRelevant, builtinIrrelevant])   , (builtinRelevant                         |-> BuiltinDataCons trelevance)   , (builtinIrrelevant                       |-> BuiltinDataCons trelevance)+    -- Quantity+  , (builtinQuantity                         |-> BuiltinData tset [builtinQuantity0, builtinQuantityω])+  , (builtinQuantity0                        |-> BuiltinDataCons tquantity)+  , (builtinQuantityω                        |-> BuiltinDataCons tquantity)+    -- Modality+  , (builtinModality                         |-> BuiltinData tset [builtinModalityConstructor])+  , (builtinModalityConstructor              |-> BuiltinDataCons (trelevance --> tquantity --> tmodality))     -- Associativity   , builtinAssoc                             |-> BuiltinData tset [builtinAssocLeft, builtinAssocRight, builtinAssocNon]   , builtinAssocLeft                         |-> BuiltinDataCons tassoc@@ -261,13 +273,15 @@   , (builtinRewrite                          |-> BuiltinUnknown Nothing verifyBuiltinRewrite)   , (builtinNil                              |-> BuiltinDataCons (hPi "A" tset (el (list v0))))   , (builtinCons                             |-> BuiltinDataCons (hPi "A" tset (tv0 --> el (list v0) --> el (list v0))))+  , (builtinNothing                          |-> BuiltinDataCons (hPi "A" tset (el (tMaybe v0))))+  , (builtinJust                             |-> BuiltinDataCons (hPi "A" tset (tv0 --> el (tMaybe v0))))   , (builtinZero                             |-> BuiltinDataCons tnat)   , (builtinSuc                              |-> BuiltinDataCons (tnat --> tnat))   , (builtinTrue                             |-> BuiltinDataCons tbool)   , (builtinFalse                            |-> BuiltinDataCons tbool)   , (builtinArgArg                           |-> BuiltinDataCons (hPi "A" tset (targinfo --> tv0 --> targ tv0)))   , (builtinAbsAbs                           |-> BuiltinDataCons (hPi "A" tset (tstring  --> tv0 --> tabs tv0)))-  , (builtinArgArgInfo                       |-> BuiltinDataCons (thiding --> trelevance --> targinfo))+  , (builtinArgArgInfo                       |-> BuiltinDataCons (thiding --> tmodality --> targinfo))   , (builtinAgdaTermVar                      |-> BuiltinDataCons (tnat --> targs --> tterm))   , (builtinAgdaTermLam                      |-> BuiltinDataCons (thiding --> tabs tterm --> tterm))   , (builtinAgdaTermExtLam                   |-> BuiltinDataCons (tlist tclause --> targs --> tterm))@@ -300,6 +314,9 @@      -- (hPi "i" tsize $ let a = el $ primSizeLt <@> v0 in (a --> a --> a)))   , (builtinAgdaSortSet                      |-> BuiltinDataCons (tterm --> tsort))   , (builtinAgdaSortLit                      |-> BuiltinDataCons (tnat --> tsort))+  , (builtinAgdaSortProp                     |-> BuiltinDataCons (tterm --> tsort))+  , (builtinAgdaSortPropLit                  |-> BuiltinDataCons (tnat --> tsort))+  , (builtinAgdaSortInf                      |-> BuiltinDataCons (tnat --> tsort))   , (builtinAgdaSortUnsupported              |-> BuiltinDataCons tsort)   , (builtinNatPlus                          |-> BuiltinPrim "primNatPlus" verifyPlus)   , (builtinNatMinus                         |-> BuiltinPrim "primNatMinus" verifyMinus)@@ -311,10 +328,14 @@   , (builtinLevelZero                        |-> BuiltinPrim "primLevelZero" (const $ return ()))   , (builtinLevelSuc                         |-> BuiltinPrim "primLevelSuc" (const $ return ()))   , (builtinLevelMax                         |-> BuiltinPrim "primLevelMax" verifyMax)-  , (builtinSetOmega                         |-> BuiltinPrim "primSetOmega" (const $ return ()))+  , (builtinSet                              |-> BuiltinSort "primSet")+  , (builtinProp                             |-> BuiltinSort "primProp")+  , (builtinSetOmega                         |-> BuiltinSort "primSetOmega")+  , (builtinSSetOmega                        |-> BuiltinSort "primStrictSetOmega")+  , (builtinStrictSet                        |-> BuiltinSort "primStrictSet")   , (builtinAgdaClause                       |-> BuiltinData tset [builtinAgdaClauseClause, builtinAgdaClauseAbsurd])-  , (builtinAgdaClauseClause                 |-> BuiltinDataCons (tlist (targ tpat) --> tterm --> tclause))-  , (builtinAgdaClauseAbsurd                 |-> BuiltinDataCons (tlist (targ tpat) --> tclause))+  , (builtinAgdaClauseClause                 |-> BuiltinDataCons (ttelescope --> tlist (targ tpat) --> tterm --> tclause))+  , (builtinAgdaClauseAbsurd                 |-> BuiltinDataCons (ttelescope --> tlist (targ tpat) --> tclause))   , (builtinAgdaDefinition                   |-> BuiltinData tset [builtinAgdaDefinitionFunDef                                                                   ,builtinAgdaDefinitionDataDef                                                                   ,builtinAgdaDefinitionDataConstructor@@ -355,31 +376,32 @@   , builtinAgdaTCMGetDefinition              |-> builtinPostulate (tqname --> tTCM_ primAgdaDefinition)   , builtinAgdaTCMQuoteTerm                  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ elV 1 (varM 0) --> tTCM_ primAgdaTerm)   , builtinAgdaTCMUnquoteTerm                |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tterm --> tTCM 1 (varM 0))+  , builtinAgdaTCMQuoteOmegaTerm             |-> builtinPostulate (hPi "A" tsetOmega $ (elInf $ varM 0) --> tTCM_ primAgdaTerm)   , builtinAgdaTCMBlockOnMeta                |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tmeta --> tTCM 1 (varM 0))   , builtinAgdaTCMCommit                     |-> builtinPostulate (tTCM_ primUnit)   , builtinAgdaTCMIsMacro                    |-> builtinPostulate (tqname --> tTCM_ primBool)   , builtinAgdaTCMWithNormalisation          |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMWithReconsParams           |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMDebugPrint                 |-> builtinPostulate (tstring --> tnat --> tlist terrorpart --> tTCM_ primUnit)+  , builtinAgdaTCMOnlyReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMDontReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+   , builtinAgdaTCMNoConstraints              |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0))-  , builtinAgdaTCMRunSpeculative          |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $-                                                                tTCM 1 (primSigma <#> varM 1 <#> primLevelZero <@> varM 0 <@>-                                                                          (Lam defaultArgInfo . Abs "_" <$> primBool)) -->-                                                                tTCM 1 (varM 0))+  , builtinAgdaTCMRunSpeculative             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $+                                                                   tTCM 1 (primSigma <#> varM 1 <#> primLevelZero <@> varM 0 <@> (Lam defaultArgInfo . Abs "_" <$> primBool)) --> tTCM 1 (varM 0))+  , builtinAgdaTCMExec                       |-> builtinPostulate (tstring --> tlist tstring --> tstring -->+                                                                   tTCM_ (primSigma <#> primLevelZero <#> primLevelZero <@> primNat <@>+                                                                          (Lam defaultArgInfo . Abs "_" <$> (primSigma <#> primLevelZero <#> primLevelZero <@> primString <@>+                                                                           (Lam defaultArgInfo . Abs "_" <$> primString)))))   ]   where         (|->) = BuiltinInfo -        v0,v1,v2,v3 :: TCM Term+        v0 :: TCM Term         v0 = varM 0-        v1 = varM 1-        v2 = varM 2-        v3 = varM 3 -        tv0,tv1 :: TCM Type+        tv0 :: TCM Type         tv0 = el v0-        tv1 = el v1-        tv2 = el v2-        tv3 = el v3          arg :: TCM Term -> TCM Term         arg t = primArg <@> t@@ -387,8 +409,15 @@         elV x a = El (varSort x) <$> a          tsetL l    = return $ sort (varSort l)+        tsetOmega  = return $ sort $ Inf IsFibrant 0         tlevel     = el primLevel         tlist x    = el $ list (fmap unEl x)+        tmaybe x   = el $ tMaybe (fmap unEl x)+        tpair lx ly x y = el $ primSigma+                            <#> lx+                            <#> ly+                            <@> fmap unEl x+                            <@> (Lam defaultArgInfo . NoAbs "_" <$> fmap unEl y)         targ x     = el (arg (fmap unEl x))         tabs x     = el (primAbs <@> fmap unEl x)         targs      = el (list (arg primAgdaTerm))@@ -406,6 +435,8 @@         tbool      = el primBool         thiding    = el primHiding         trelevance = el primRelevance+        tquantity  = el primQuantity+        tmodality  = el primModality         tassoc     = el primAssoc         tprec      = el primPrecedence         tfixity    = el primFixity@@ -417,9 +448,10 @@         tliteral   = el primAgdaLiteral         tpat       = el primAgdaPattern         tclause    = el primAgdaClause+        ttelescope = tlist (tpair primLevelZero primLevelZero tstring (targ ttype))         tTCM l a   = elV l (primAgdaTCM <#> varM l <@> a)         tTCM_ a    = el (primAgdaTCM <#> primLevelZero <@> a)-        tinterval  = El Inf <$> primInterval+        tinterval  = El (SSet $ ClosedLevel 0) <$> primInterval          verifyPlus plus =             verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do@@ -539,17 +571,15 @@         verifyPath :: Term -> Type -> TCM ()         verifyPath path t = do           let hlam n t = glam (setHiding Hidden defaultArgInfo) n t-          noConstraints $ equalTerm t path =<< (runNamesT [] $-            hlam "l" $ \ l -> hlam "A" $ \ bA -> cl primPathP <#> l <@> (lam "i" $ \ _ -> bA))+          noConstraints $ equalTerm t path =<< runNamesT [] (+            hlam "l" $ \ l -> hlam "A" $ \ bA -> cl primPathP <#> l <@> lam "i" (\ _ -> bA))  -- | Checks that builtin with name @b : String@ of type @t : Term@ --   is a data type or inductive record with @n : Int@ constructors. --   Returns the name of the data/record type. inductiveCheck :: String -> Int -> Term -> TCM (QName, Definition) inductiveCheck b n t = do-  t <- etaContract =<< normalise t-  case t of-    Def q _ -> do+  caseMaybeM (headSymbol t) no $ \q -> do       def <- getConstInfo q       let yes = return (q, def)       case theDef def of@@ -558,8 +588,13 @@           | otherwise      -> no         Record { recInduction = ind } | n == 1 && ind /= Just CoInductive -> yes         _ -> no-    _ -> no   where+  headSymbol :: Term -> TCM (Maybe QName)+  headSymbol t = reduce t >>= \case+    Def q _ -> return $ Just q+    Lam _ b -> headSymbol $ lazyAbsApp b __DUMMY_TERM__+    _       -> return Nothing+   no     | n == 1 = typeError $ GenericError $ unwords         [ "The builtin", b@@ -585,11 +620,12 @@     Axiom {} -> bindBuiltinName builtin =<< m q def     _        -> err   where+  err :: forall m a. MonadTCError m => m a   err = typeError $ GenericError $           "The argument to BUILTIN " ++ builtin ++           " must be a postulated name"   getName = \case-    DefinedName _ d -> return $ anameName d+    DefinedName _ d NoSuffix -> return $ anameName d     _ -> err  addHaskellPragma :: QName -> String -> TCM ()@@ -710,7 +746,7 @@           (a,b) <- reduce $ fromMaybe __IMPOSSIBLE__ $ last2 vs           unless (deBruijnView a == Just 0) wrongRefl           unless (deBruijnView b == Just 0) wrongRefl-          bindBuiltinName builtinRefl (Con (ConHead c Inductive []) ConOSystem [])+          bindBuiltinName builtinRefl (Con (ConHead c IsData Inductive []) ConOSystem [])         _ -> __IMPOSSIBLE__     _ -> genericError "Builtin EQUALITY must be a data type with a single constructor"   where@@ -730,6 +766,7 @@            | s == builtinUnit     -> bindBuiltinUnit     v            | s == builtinSigma    -> bindBuiltinSigma    v            | s == builtinList     -> bindBuiltinData s   v+           | s == builtinMaybe    -> bindBuiltinData s   v            | otherwise            -> bindBuiltinName s   v        BuiltinDataCons t -> do@@ -745,7 +782,6 @@           _       -> typeError $ BuiltinMustBeConstructor s e          let v@(Con h _ []) = name v0-            c = conName h          bindBuiltinName s v @@ -777,6 +813,8 @@            _ -> typeError $ GenericError $ "Builtin " ++ s ++ " must be bound to a function" +      BuiltinSort{} -> __IMPOSSIBLE__ -- always a "BuiltinNoDef"+       BuiltinPostulate rel t -> do         t' <- t         v <- applyRelevanceToContext rel $ checkExpr e t'@@ -789,11 +827,11 @@               Axiom {} -> do                 builtinSizeHook s q t'                 -- And compilation pragmas for base types-                when (s == builtinLevel)  $ addHaskellPragma q "= type ()"-                when (s == builtinChar)   $ addHaskellPragma q "= type Char"-                when (s == builtinString) $ addHaskellPragma q "= type Data.Text.Text"-                when (s == builtinFloat)  $ addHaskellPragma q "= type Double"-                when (s == builtinWord64) $ addHaskellPragma q "= type MAlonzo.RTE.Word64"+                when (s == builtinLevel)  $ setConstTranspAxiom q >> addHaskellPragma q "= type ()"+                when (s == builtinChar)   $ setConstTranspAxiom q >> addHaskellPragma q "= type Char"+                when (s == builtinString) $ setConstTranspAxiom q >> addHaskellPragma q "= type Data.Text.Text"+                when (s == builtinFloat)  $ setConstTranspAxiom q >> addHaskellPragma q "= type Double"+                when (s == builtinWord64) $ setConstTranspAxiom q >> addHaskellPragma q "= type MAlonzo.RTE.Word64"                 when (s == builtinPathP)  $ builtinPathPHook q                 bindBuiltinName s v               _        -> err@@ -806,6 +844,10 @@         f v t         bindBuiltinName s v +setConstTranspAxiom :: QName -> TCM ()+setConstTranspAxiom q =+  modifySignature $ updateDefinition q $ updateTheDef (const $ constTranspAxiom)+ builtinPathPHook :: QName -> TCM () builtinPathPHook q =       modifySignature $ updateDefinition q@@ -818,13 +860,16 @@   unlessM ((0 ==) <$> getContextSize) $ do     -- Andreas, 2017-11-01, issue #2824     -- Only raise an error if the name for the builtin is defined in a parametrized module.-    let failure = typeError $ BuiltinInParameterisedModule b+    let+      failure :: forall m a. MonadTCError m => m a+      failure = typeError $ BuiltinInParameterisedModule b     -- Get the non-empty list of AbstractName for x     xs <- case x of       VarName{}            -> failure-      DefinedName _ x      -> return $ x :| []+      DefinedName _ x NoSuffix -> return $ x :| []+      DefinedName _ x Suffix{} -> failure       FieldName xs         -> return xs-      ConstructorName xs   -> return xs+      ConstructorName _ xs -> return xs       PatternSynResName xs -> failure       UnknownName          -> failure     -- For ambiguous names, we check all of their definitions:@@ -848,13 +893,25 @@     now new b = warning $ OldBuiltin b new  isUntypedBuiltin :: String -> Bool-isUntypedBuiltin b = elem b [builtinFromNat, builtinFromNeg, builtinFromString]+isUntypedBuiltin = hasElem [ builtinFromNat, builtinFromNeg, builtinFromString ]  bindUntypedBuiltin :: String -> ResolvedName -> TCM () bindUntypedBuiltin b = \case-  DefinedName _ x -> bindBuiltinName b (Def (anameName x) [])-  FieldName (x :| []) -> bindBuiltinName b (Def (anameName x) [])-  _ -> genericError $ "The argument to BUILTIN " ++ b ++ " must be a defined unambiguous name"+  DefinedName _ x NoSuffix -> bind x+  DefinedName _ x Suffix{} -> wrong+  FieldName (x :| [])  -> bind x+  FieldName (x :| _)   -> amb x+  VarName _x _bnd      -> wrong+  UnknownName          -> wrong+  ConstructorName _ xs -> err xs+  PatternSynResName xs -> err xs+  where+  bind x = bindBuiltinName b (Def (anameName x) [])+  wrong  = genericError $ "The argument to BUILTIN " ++ b ++ " must be a defined name"+  amb x  = genericDocError =<< do text "Name " <+> prettyTCM x <+> text " is ambiguous"+  err (x :| xs1)+    | null xs1  = wrong+    | otherwise = amb x  -- | Bind a builtin thing to a new name. --@@ -885,7 +942,7 @@                 , funMutual    = Just []                 , funTerminates = Just True                 }-            | otherwise = Axiom+            | otherwise = defaultAxiom      Just (BuiltinPrim name axioms) -> do       PrimImpl t pf <- lookupPrimitiveFunction name@@ -905,7 +962,7 @@       t <- mt       d <- return $! getPrimName $ unEl t       let-        ch = ConHead q Inductive []+        ch = ConHead q IsData Inductive []         def = Constructor               { conPars   = 0   -- Andrea TODO: fix zeros               , conArity  = 0@@ -924,30 +981,43 @@      Just (BuiltinData mt cs) -> do       t <- mt-      addConstant q $ defaultDefn defaultArgInfo q t def+      addConstant q $ defaultDefn defaultArgInfo q t (def t)       bindBuiltinName b $ Def q []       where-        def = Datatype+        def t = Datatype               { dataPars       = 0               , dataIxs        = 0               , dataClause     = Nothing               , dataCons       = []     -- Constructors are added later-              , dataSort       = Inf+              , dataSort       = getSort t               , dataAbstr      = ConcreteDef               , dataMutual     = Nothing               , dataPathCons   = []               } +    Just (BuiltinSort sortname) -> do+      let s = case sortname of+                "primSet"      -> mkType 0+                "primProp"     -> mkProp 0+                "primStrictSet" -> mkSSet 0+                "primSetOmega" -> Inf IsFibrant 0+                "primStrictSetOmega" -> Inf IsStrict 0+                _              -> __IMPOSSIBLE__+          def = PrimitiveSort sortname s+      addConstant q $ defaultDefn defaultArgInfo q (sort $ univSort s) def+      bindBuiltinName b $ Def q []+     Just{}  -> __IMPOSSIBLE__     Nothing -> __IMPOSSIBLE__ -- typeError $ NoSuchBuiltinName b   builtinKindOfName :: String -> Maybe KindOfName-builtinKindOfName b = distinguish <$> find ((b ==) . builtinName) coreBuiltins+builtinKindOfName = distinguish <.> findBuiltinInfo   where   distinguish d = case builtinDesc d of     BuiltinDataCons{}  -> ConName-    BuiltinData{}      -> DataName+    BuiltinData{}      -> DataName       -- Andreas, 2020-04-13: Crude.  Could be @RecName@.     BuiltinPrim{}      -> PrimName     BuiltinPostulate{} -> AxiomName+    BuiltinSort{}      -> PrimName     BuiltinUnknown{}   -> OtherDefName

src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs view

@@ -14,7 +14,6 @@ import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Primitive import Agda.TypeChecking.Reduce@@ -75,11 +74,12 @@                   { recPars           = 2                   , recInduction      = Just CoInductive                   , recClause         = Nothing-                  , recConHead        = ConHead sharp CoInductive []  -- flat is added later+                  , recConHead        = ConHead sharp (IsRecord CopatternMatching) CoInductive []  -- flat is added later                   , recNamedCon       = True                   , recFields         = []  -- flat is added later                   , recTel            = fieldTel-                  , recEtaEquality'   = Inferred NoEta+                  , recEtaEquality'   = Inferred $ NoEta CopatternMatching+                  , recPatternMatching= CopatternMatching                   , recMutual         = Just []                   , recAbstr          = ConcreteDef                   , recComp           = emptyCompKit@@ -89,7 +89,7 @@       sharpDefn { theDef = Constructor                     { conPars   = 2                     , conArity  = 1-                    , conSrcCon = ConHead sharp CoInductive [] -- flat is added as field later+                    , conSrcCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [] -- flat is added as field later                     , conData   = defName infDefn                     , conAbstr  = ConcreteDef                     , conInd    = CoInductive@@ -115,7 +115,7 @@     Def sharp _ <- primSharp     kit         <- requireLevels     Def inf _   <- primInf-    let sharpCon = ConHead sharp CoInductive [defaultArg flat]+    let sharpCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [defaultArg flat]         level    = El (mkType 0) $ Def (typeName kit) []         tel     :: Telescope         tel      = ExtendTel (domH $ level)                  $ Abs "a" $@@ -134,6 +134,7 @@           , clauseBody      = Just $ var 0           , clauseType      = Just $ defaultArg $ El (varSort 2) $ var 1           , clauseCatchall  = False+          , clauseExact       = Just True           , clauseRecursive   = Just False           , clauseUnreachable = Just False           , clauseEllipsis  = NoEllipsis

src/full/Agda/TypeChecking/Rules/Data.hs view

@@ -5,11 +5,10 @@ import Prelude hiding (null)  import Control.Monad+import Control.Monad.Except import Control.Monad.Trans import Control.Monad.Trans.Maybe -import Data.Foldable (traverse_)-import Data.Maybe (fromMaybe, catMaybes, isJust) import Data.Set (Set) import qualified Data.Set as Set @@ -21,11 +20,9 @@ import Agda.Syntax.Position import qualified Agda.Syntax.Info as Info import Agda.Syntax.Scope.Monad-import Agda.Syntax.Fixity  import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin -- (primLevel) import Agda.TypeChecking.Conversion import Agda.TypeChecking.Substitute import Agda.TypeChecking.Generalize@@ -43,8 +40,9 @@  import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ ) -import Agda.Utils.Except import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -151,7 +149,7 @@                   , dataPathCons   = []     -- Path constructors are added later                   } -            escapeContext __IMPOSSIBLE__ npars $ do+            escapeContext impossible npars $ do               addConstant name $                 defaultDefn defaultArgInfo name t dataDef                 -- polarity and argOcc.s determined by the positivity checker@@ -164,8 +162,7 @@             -- Return the data definition             return dataDef{ dataPathCons = catMaybes pathCons } -        let s      = dataSort dataDef-            cons   = map A.axiomName cs  -- get constructor names+        let cons   = map A.axiomName cs  -- get constructor names          -- Add the datatype to the signature with its constructors.         -- It was previously added without them.@@ -214,10 +211,11 @@           NonStrict  -> typeError $ GenericError $ "Shape-irrelevant constructors are not supported"         case getQuantity ai of           Quantityω{} -> return ()-          Quantity0{} -> typeError $ GenericError $ "Erased constructors are not supported"+          Quantity0{} -> return ()           Quantity1{} -> typeError $ GenericError $ "Quantity-restricted constructors are not supported"         -- check that the type of the constructor is well-formed-        (t, isPathCons) <- checkConstructorType e d+        (t, isPathCons) <- applyQuantityToContext ai $+                           checkConstructorType e d         -- compute which constructor arguments are forced (only point constructors)         forcedArgs <- if isPathCons == PointCons                       then computeForcingAnnotations c t@@ -231,7 +229,9 @@         let s' = case s of               Prop l -> Type l               _      -> s-        arity <- traceCall (CheckConstructorFitsIn c t s') $ fitsIn uc forcedArgs t s'+        arity <- traceCall (CheckConstructorFitsIn c t s') $+                 applyQuantityToContext ai $+                 fitsIn uc forcedArgs t s'         -- this may have instantiated some metas in s, so we reduce         s <- reduce s         debugAdd c t@@ -242,10 +242,7 @@         -- of the datatype in an empty context (c.f. getContextSize above).         params <- getContextTelescope -        -- Cannot compose indexed inductive types yet.-        (con, comp, projNames) <- if nofIxs /= 0 || (Info.defAbstract i == AbstractDef)-          then return (ConHead c Inductive [], emptyCompKit, Nothing)-          else do+        (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@@ -261,17 +258,20 @@               , "names  =" <+> pretty names               ] -            let con = ConHead c Inductive $ zipWith (<$) names $ map argFromDom $ telToList fields+            let con = ConHead c IsData Inductive $ zipWith (<$) names $ map argFromDom $ telToList fields              defineProjections d con params names fields dataT-            comp <- inTopContext $ defineCompData d con params names fields dataT boundary+            -- Cannot compose indexed inductive types yet.+            comp <- if nofIxs /= 0 || (Info.defAbstract i == AbstractDef)+                    then return emptyCompKit+                    else inTopContext $ defineCompData d con params names fields dataT boundary             return (con, comp, Just names)          -- add parameters to constructor type and put into signature-        escapeContext __IMPOSSIBLE__ (size tel) $ do+        escapeContext impossible (size tel) $ do            addConstant c $-            defaultDefn defaultArgInfo c (telePi tel t) $ Constructor+            defaultDefn ai c (telePi tel t) $ Constructor               { conPars   = size tel               , conArity  = arity               , conSrcCon = con@@ -374,7 +374,7 @@     defineTranspOrHCompD cmd d con params names fsT t boundary = do       let project = (\ t p -> apply (Def p []) [argN t])       stuff <- defineTranspOrHCompForFields cmd-                 (guard (not $ null boundary) >> (Just $ Con con ConOSystem $ teleElims fsT boundary))+                 (guard (not $ null boundary) >> Just (Con con ConOSystem $ teleElims fsT boundary))                  project d params fsT (map argN names) t       caseMaybe stuff (return Nothing) $ \ ((theName, gamma , ty, _cl_types , bodies), theSub) -> do @@ -439,7 +439,7 @@               ineg r = pure tINeg <@> r               lvlOfType = (\ (Type l) -> Level l) . getSort               pOr la i j u0 u1 = pure tPOr <#> (lvlOfType <$> la) <@> i <@> j-                                           <#> (ilam "o" $ \ _ -> unEl <$> la) <@> u0 <@> u1+                                           <#> ilam "o" (\ _ -> unEl <$> la) <@> u0 <@> u1               absAp x y = liftM2 absApp x y                mkFace (r,(u1,u2)) = runNamesT [] $ do@@ -455,8 +455,8 @@                   let                     -- Γ, i ⊢ squeeze u = primTrans (\ j -> ty [i := i ∨ j]) (φ ∨ i) u                     squeeze u = cl primTrans-                                          <#> (lam "j" $ \ j -> lvlOfType <$> ty `absAp` (imax i j))-                                          <@> (lam "j" $ \ j -> unEl <$> ty `absAp` (imax i j))+                                          <#> lam "j" (\ j -> lvlOfType <$> ty `absAp` (imax i j))+                                          <@> lam "j" (\ j -> unEl <$> ty `absAp` (imax i j))                                           <@> (phi `imax` i)                                           <@> u                   alpha <- pOr (ty `absAp` i)@@ -531,6 +531,7 @@           , clauseLHSRange    = noRange           , clauseCatchall    = False           , clauseBody        = Just $ body+          , clauseExact       = Just True           , clauseRecursive   = Nothing               -- Andreas 2020-02-06 TODO               -- Or: Just False;  is it known to be non-recursive?@@ -623,7 +624,7 @@   freshAbstractQName'_ :: String -> TCM QName-freshAbstractQName'_ s = freshAbstractQName noFixity' (C.Name noRange C.InScope [C.Id $ s])+freshAbstractQName'_ = freshAbstractQName noFixity' . C.simpleName   -- * Special cases of Type@@ -646,16 +647,17 @@     Type l -> return $ Just $ LEl l (unEl ty)     _      -> return $ Nothing -instance Subst Term LType where+instance Subst LType where+  type SubstArg LType = Term   applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t)  -- | A @Type@ that either has sort @Type l@ or is a closed definition. --   Such a type supports some version of transp. --   In particular we want to allow the Interval as a @ClosedType@.-data CType = ClosedType QName | LType LType deriving (Eq,Show)+data CType = ClosedType Sort QName | LType LType deriving (Eq,Show)  fromCType :: CType -> Type-fromCType (ClosedType q) = El Inf (Def q [])+fromCType (ClosedType s q) = El s (Def q []) fromCType (LType t) = fromLType t  toCType :: MonadReduce m => Type -> m (Maybe CType)@@ -663,15 +665,16 @@   sort <- reduce $ getSort ty   case sort of     Type l -> return $ Just $ LType (LEl l (unEl ty))-    Inf    -> do+    SSet l  -> do       t <- reduce (unEl ty)       case t of-        Def q [] -> return $ Just $ ClosedType q+        Def q [] -> return $ Just $ ClosedType (SSet l) q         _        -> return $ Nothing     _      -> return $ Nothing -instance Subst Term CType where-  applySubst rho t@ClosedType{} = t+instance Subst CType where+  type SubstArg CType = Term+  applySubst rho (ClosedType s t) = ClosedType (applySubst rho s) t   applySubst rho (LType t) = LType $ applySubst rho t  @@ -708,7 +711,7 @@   -> Type        -- ^ record type Δ ⊢ T   -> TCM ((QName, Telescope, Type, [Dom Type], [Term]), Substitution) defineTranspForFields pathCons applyProj name params fsT fns rect = do-  interval <- elInf primInterval+  interval <- primIntervalType   let deltaI = expTelescope interval params   iz <- primIZero   io <- primIOne@@ -716,8 +719,8 @@   imax <- getPrimitiveTerm "primIMax"   ineg <- getPrimitiveTerm "primINeg"   transp <- getPrimitiveTerm builtinTrans-  por <- getPrimitiveTerm "primPOr"-  one <- primItIsOne+  -- por <- getPrimitiveTerm "primPOr"+  -- one <- primItIsOne   reportSDoc "trans.rec" 20 $ text $ show params   reportSDoc "trans.rec" 20 $ text $ show deltaI   reportSDoc "trans.rec" 10 $ text $ show fsT@@ -730,7 +733,7 @@   theType <- (abstract deltaI <$>) $ runNamesT [] $ do               rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in                                                              pure rect')-              nPi' "phi" (elInf $ cl primInterval) $ \ phi ->+              nPi' "phi" primIntervalType $ \ phi ->                (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io)    reportSDoc "trans.rec" 20 $ prettyTCM theType@@ -754,7 +757,7 @@                        flattenTel (singletonS 0 io `applySubst` fsT') -- Γ, Φ[δ i1] ⊢ flatten Φ[δ i1]        -- Γ, i : I ⊢ [δ i] : Δ-      delta_i = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params)+      delta_i = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params) -- Defined but not used        -- Γ, i : I ⊢ Φ[δ i]       fsT' = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params)  `applySubst`@@ -871,7 +874,7 @@   -> LType        -- ^ record type (δ : Δ) ⊢ R[δ]   -> TCM ((QName, Telescope, Type, [Dom Type], [Term]),Substitution) defineHCompForFields applyProj name params fsT fns rect = do-  interval <- elInf primInterval+  interval <- primIntervalType   let delta = params   iz <- primIZero   io <- primIOne@@ -894,8 +897,8 @@    theType <- (abstract delta <$>) $ runNamesT [] $ do               rect <- open $ fromLType rect-              nPi' "phi" (elInf $ cl primInterval) $ \ phi ->-               (nPi' "i" (elInf $ cl primInterval) $ \ i ->+              nPi' "phi" primIntervalType $ \ phi ->+               nPi' "i" primIntervalType (\ i ->                 pPi' "o" phi $ \ _ -> rect) -->                rect --> rect @@ -941,14 +944,12 @@           u <- lam "j" (\ j -> pure por <#> lvl                                         <@> phi                                         <@> (pure ineg <@> i)-                                        <#> (lam "_" $ \ o -> rect)+                                        <#> lam "_" (\ o -> rect)                                         <@> (w <@> (pure imin <@> i <@> j))-                                        <@> (lam "_" $ \ o -> w0) -- TODO wait for i = 0+                                        <@> lam "_" (\ o -> w0) -- TODO wait for i = 0                        )           u0 <- w0           pure $ Def theName [] `apply` (args ++ [argN psi, argN u, argN u0])-        where-          underArg k m = Arg <$> (argInfo <$> m) <*> (k (unArg <$> m))        -- (γ : Γ) ⊢ (flatten Φ)[n ↦ f_n (compR γ)]       clause_types = parallelS [compTerm `applyProj` (unArg fn)@@ -967,13 +968,13 @@   comp <- do         let           imax i j = pure tIMax <@> i <@> j-        let forward la bA r u = pure transp <#> (lam "i" $ \ i -> la <@> (i `imax` r))-                                            <@> (lam "i" $ \ i -> bA <@> (i `imax` r))+        let forward la bA r u = pure transp <#> lam "i" (\ i -> la <@> (i `imax` r))+                                            <@> lam "i" (\ i -> bA <@> (i `imax` r))                                             <@> r                                             <@> u         return $ \ la bA phi u u0 ->           pure hcomp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                      <@> (lam "i" $ \ i -> ilam "o" $ \ o ->+                      <@> lam "i" (\ i -> ilam "o" $ \ o ->                               forward la bA i (u <@> i <..> o))                       <@> forward la bA (pure iz) u0   let@@ -1061,7 +1062,7 @@   typeError . GenericDocError =<< do     let s | length xs > 1 = "s"           | otherwise     = ""-    text ("Unexpected type signature for parameter" ++ s) <+> sep (map prettyA xs)+    text ("Unexpected type signature for parameter" ++ s) <+> sep (fmap prettyA xs)  bindParameters _ (A.DomainFull A.TLet{} : _) _ _ = __IMPOSSIBLE__ @@ -1083,7 +1084,7 @@       typeError . GenericDocError =<< do         text ("No parameter of name " ++ x)   where-    Pi dom@(Dom{domInfo = info', unDom = a}) b = unEl t+    Pi dom@(Dom{domInfo = info', unDom = a}) b = unEl t -- TODO:: Defined but not used: info', a     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@@ -1095,6 +1096,10 @@ -- | Check that the arguments to a constructor fits inside the sort of the datatype. --   The third argument is the type of the constructor. --+--   When @--without-K@ is active and the type is fibrant the+--   procedure also checks that the type is usable at the current+--   modality. See #4784 and #5434.+-- --   As a side effect, return the arity of the constructor.  fitsIn :: UniverseCheck -> [IsForced] -> Type -> Sort -> TCM Int@@ -1109,26 +1114,33 @@   -- s' <- instantiateFull (getSort t)   -- noConstraints $ s' `leqSort` s +  withoutK <- withoutKOption+  when withoutK $ whenM (isFibrant s) $ do+    q <- viewTC eQuantity+    usableAtModality (setQuantity q defaultModality) (unEl t) -  vt <- do-    t <- pathViewAsPi t-    return $ case t of-                  Left (a,b)     -> Just (True ,a,b)-                  Right (El _ t) | Pi a b <- t-                                 -> Just (False,a,b)-                  _              -> Nothing-  case vt of-    Just (isPath, dom, b) -> do-      withoutK <- withoutKOption-      let (forced,forceds') = nextIsForced forceds-      unless (isForced forced && not withoutK) $ do-        sa <- reduce $ getSort dom-        unless (isPath || uc == NoUniverseCheck || sa == SizeUniv) $ sa `leqSort` s-      addContext (absName b, dom) $ do-        succ <$> fitsIn uc forceds' (absBody b) (raise 1 s)-    _ -> do-      getSort t `leqSort` s-      return 0+  fitsIn' withoutK forceds t s+  where+  fitsIn' withoutK forceds t s = do+    vt <- do+      t <- pathViewAsPi t+      return $ case t of+                    Left (a,b)     -> Just (True ,a,b)+                    Right (El _ t) | Pi a b <- t+                                   -> Just (False,a,b)+                    _              -> Nothing+    case vt of+      Just (isPath, dom, b) -> do+        let (forced,forceds') = nextIsForced forceds+        unless (isForced forced && not withoutK) $ do+          sa <- reduce $ getSort dom+          unless (isPath || uc == NoUniverseCheck || sa == SizeUniv) $+            sa `leqSort` s+        addContext (absName b, dom) $ do+          succ <$> fitsIn' withoutK forceds' (absBody b) (raise 1 s)+      _ -> do+        getSort t `leqSort` s+        return 0  -- | When --without-K is enabled, we should check that the sorts of --   the index types fit into the sort of the datatype.@@ -1136,7 +1148,9 @@ checkIndexSorts s = \case   EmptyTel -> return ()   ExtendTel a tel' -> do-    getSort a `leqSort` s+    let sa = getSort a+    -- Andreas, 2020-10-19, allow Size indices+    unless (sa == SizeUniv) $ sa `leqSort` s     underAbstraction a tel' $ checkIndexSorts (raise 1 s)  -- | Return the parameters that share variables with the indices@@ -1170,7 +1184,7 @@                       return PathCons                 Def d es | d == q -> do                   let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-                  (pars, ixs) <- normalise $ splitAt nofPars vs+                  let (pars, ixs) = splitAt nofPars vs                   -- check that the constructor parameters are the data parameters                   checkParams n pars                   return PointCons@@ -1206,24 +1220,6 @@                     equalTerm t (unArg arg) (var i)  -{- UNUSED, Andreas 2012-09-13--- | Force a type to be a specific datatype.-forceData :: QName -> Type -> TCM Type-forceData d (El s0 t) = liftTCM $ do-    t' <- reduce t-    d  <- canonicalName d-    case t' of-        Def d' _-            | d == d'   -> return $ El s0 t'-            | otherwise -> fail $ "wrong datatype " ++ show d ++ " != " ++ show d'-        MetaV m vs          -> do-            Defn {defType = t, theDef = Datatype{dataSort = s}} <- getConstInfo d-            ps <- newArgsMeta t-            noConstraints $ leqType (El s0 t') (El s (Def d ps)) -- TODO: need equalType?-            reduce $ El s0 t'-        _ -> typeError $ ShouldBeApplicationOf (El s0 t) d--}- -- | Is the type coinductive? Returns 'Nothing' if the answer cannot -- be determined. @@ -1243,6 +1239,7 @@         GeneralizableVar{} -> __IMPOSSIBLE__         Constructor {} -> __IMPOSSIBLE__         Primitive   {} -> __IMPOSSIBLE__+        PrimitiveSort{} -> __IMPOSSIBLE__         AbstractDefn{} -> __IMPOSSIBLE__     Var   {} -> return Nothing     Lam   {} -> __IMPOSSIBLE__

src/full/Agda/TypeChecking/Rules/Decl.hs view

@@ -9,7 +9,6 @@  import Data.Either (partitionEithers) import qualified Data.Foldable as Fold-import qualified Data.List as List import Data.Maybe import qualified Data.Set as Set import qualified Data.IntSet as IntSet@@ -25,9 +24,9 @@ import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Literal+import Agda.Syntax.Scope.Base ( KindOfName(..) )  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Benchmark (MonadBench, Phase) import qualified Agda.TypeChecking.Monad.Benchmark as Bench @@ -79,23 +78,18 @@ -- | Cached checkDecl checkDeclCached :: A.Declaration -> TCM () checkDeclCached d@A.ScopedDecl{} = checkDecl d-checkDeclCached d@(A.Section minfo mname (A.GeneralizeTel _ tbinds) _) = do+checkDeclCached d@(A.Section _ 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)   case e of-    Just (EnterSection minfo' mname' tbinds', _)-      | killRange minfo == killRange minfo' && mname == mname' && tbinds == tbinds' -> do-        return ()-    _ -> do-      cleanCachedLog-  writeToCurrentLog $ EnterSection minfo mname tbinds+    Just (EnterSection mname' tbinds', _)+      | mname == mname' && tbinds == tbinds' -> return ()+    _ -> cleanCachedLog+  writeToCurrentLog $ EnterSection mname tbinds   checkDecl d-  e' <- readFromCachedLog-  case e' of-    Just (LeaveSection mname', _) | mname == mname' -> do-      return ()-    _ -> do-      cleanCachedLog+  readFromCachedLog >>= \case+    Just (LeaveSection mname', _) | mname == mname' -> return ()+    _ -> cleanCachedLog   writeToCurrentLog $ LeaveSection mname  checkDeclCached d = do@@ -106,7 +100,7 @@     case e of       (Just (Decl d',s)) | compareDecl d d' -> do         restorePostScopeState s-        reportSLn "cache.decl" 50 $ "range: " ++ show (getRange d)+        reportSLn "cache.decl" 50 $ "range: " ++ prettyShow (getRange d)         printSyntaxInfo (getRange d)       _ -> do         cleanCachedLog@@ -154,15 +148,15 @@       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.Section i x tel ds     -> meta $ checkSection i x tel ds+      A.Section _r x tel ds    -> meta $ checkSection x tel ds       A.Apply i x modapp ci _adir -> meta $ checkSectionApplication i x modapp ci       A.Import i x _adir       -> none $ checkImport i x       A.Pragma i p             -> none $ checkPragma i p       A.ScopedDecl scope ds    -> none $ setScope scope >> mapM_ checkDeclCached ds       A.FunDef i x delayed cs  -> impossible $ check x i $ checkFunDef delayed 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 ind eta c ps tel cs -> impossible $ check x i $ do-                                    checkRecDef i x uc ind eta c ps tel cs+      A.RecDef i x uc dir ps tel cs -> impossible $ check x i $ do+                                    checkRecDef i x uc dir ps tel cs                                     blockId <- mutualBlockOf x                                      -- Andreas, 2016-10-01 testing whether@@ -178,8 +172,8 @@                                           ]                                      return (blockId, Set.singleton x)-      A.DataSig i x ps t       -> impossible $ checkSig i x ps t-      A.RecSig i x ps t        -> none $ checkSig i x ps t+      A.DataSig i x ps t       -> impossible $ checkSig DataName i x ps t+      A.RecSig i x ps t        -> none $ checkSig RecName i x ps t                                   -- A record signature is always followed by a                                   -- record definition. Metas should not be                                   -- frozen until after the definition has been@@ -226,12 +220,13 @@     where      -- check record or data type signature-    checkSig i x gtel t = checkTypeSignature' (Just gtel) $-      A.Axiom A.NoFunSig i defaultArgInfo Nothing x t+    checkSig kind i x gtel t = checkTypeSignature' (Just gtel) $+      A.Axiom kind i defaultArgInfo Nothing x t -    -- | Switch maybe to abstract mode, benchmark, and debug print bracket.+    -- Switch maybe to abstract mode, benchmark, and debug print bracket.     check :: forall m i a-          . ( MonadTCEnv m, MonadPretty m, MonadDebug m, MonadBench Phase m+          . ( MonadTCEnv m, MonadPretty m, MonadDebug m+            , MonadBench m, Bench.BenchPhase m ~ Phase             , AnyIsAbstract i )           => QName -> i -> m a -> m a     check x i m = Bench.billTo [Bench.Definition x] $ do@@ -241,7 +236,7 @@       reportSDoc "tc.decl" 5 $ ("Checked" <+> prettyTCM x) <> "."       return r -    -- | Switch to AbstractMode if any of the i is AbstractDef.+    -- Switch to AbstractMode if any of the i is AbstractDef.     checkMaybeAbstractly :: forall m i a . ( MonadTCEnv m , AnyIsAbstract i )                          => i -> m a -> m a     checkMaybeAbstractly = localTC . set lensIsAbstract . anyIsAbstract@@ -409,8 +404,7 @@       highlight (A.Section i x tel [])       when (hlmod == DoHighlightModuleContents) $ mapM_ (highlight_ hlmod) (deepUnscopeDecls ds)     A.RecSig{}               -> highlight d-    A.RecDef i x uc ind eta c ps tel cs ->-      highlight (A.RecDef i x uc ind eta c A.noDataDefParams dummy cs)+    A.RecDef i x uc dir ps tel cs -> highlight (A.RecDef i x uc dir A.noDataDefParams dummy cs)       -- The telescope has already been highlighted.       where       -- Andreas, 2016-01-22, issue 1790@@ -419,10 +413,10 @@       -- generate highlighting from it.       -- Simply because all the highlighting info is wrong       -- in the record constructor type:-      -- * fields become bound variables,-      -- * declarations become let-bound variables.+      -- i) fields become bound variables,+      -- ii) declarations become let-bound variables.       -- We do not need that crap.-      dummy = A.Lit $ LitString noRange $+      dummy = A.Lit empty $ LitString $         "do not highlight construct(ed/or) type"  -- | Termination check a declaration.@@ -450,7 +444,8 @@ --   for the old coinduction.) checkCoinductiveRecords :: [A.Declaration] -> TCM () checkCoinductiveRecords ds = forM_ ds $ \case-  A.RecDef _ q _ (Just (Ranged r CoInductive)) _ _ _ _ _ -> setCurrentRange r $ do+  A.RecDef _ q _ dir _ _ _+    | Just (Ranged r CoInductive) <- recInductive dir -> setCurrentRange r $ do     unlessM (isRecursiveRecord q) $ typeError $ GenericError $       "Only recursive records can be coinductive"   _ -> return ()@@ -523,8 +518,7 @@ -- | Freeze metas created by given computation if in abstract mode. whenAbstractFreezeMetasAfter :: A.DefInfo -> TCM a -> TCM a whenAbstractFreezeMetasAfter Info.DefInfo{ defAccess, defAbstract} m = do-  let pubAbs = defAccess == PublicAccess && defAbstract == AbstractDef-  if not pubAbs then m else do+  if defAbstract /= AbstractDef then m else do     (a, ms) <- metasCreatedBy m     reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing."     wakeupConstraints_   -- solve emptiness and instance constraints@@ -545,7 +539,7 @@      -- Check the signature and collect the created metas.     (telNames, tGen) <--      generalizeType s $ locallyTC eGeneralizeMetas (const YesGeneralize) $+      generalizeType s $ locallyTC eGeneralizeMetas (const YesGeneralizeMeta) $         workOnTypes $ isType_ e     let n = length telNames @@ -559,16 +553,16 @@   -- | Type check an axiom.-checkAxiom :: A.Axiom -> A.DefInfo -> ArgInfo ->+checkAxiom :: KindOfName -> A.DefInfo -> ArgInfo ->               Maybe [Occurrence] -> QName -> A.Expr -> TCM () checkAxiom = checkAxiom' Nothing  -- | 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 -> A.Axiom -> A.DefInfo -> ArgInfo ->+checkAxiom' :: Maybe A.GeneralizeTelescope -> KindOfName -> A.DefInfo -> ArgInfo ->                Maybe [Occurrence] -> QName -> A.Expr -> TCM ()-checkAxiom' gentel funSig i info0 mp x e = whenAbstractFreezeMetasAfter i $ defaultOpenLevelsToZero $ do+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.@@ -607,7 +601,7 @@     , nest 2 $ "of sort " <+> prettyTCM (getSort t)     ] -  when (not $ null genParams) $+  unless (null genParams) $     reportSLn "tc.decl.ax" 40 $ "  generalized params: " ++ show genParams    -- Jesper, 2018-06-05: should be done AFTER generalizing@@ -616,7 +610,7 @@    -- Andreas, 2015-03-17 Issue 1428: Do not postulate sizes in parametrized   -- modules!-  when (funSig == A.NoFunSig) $ do+  when (kind == AxiomName) $ do     whenM ((== SizeUniv) <$> do reduce $ getSort t) $ do       whenM ((> 0) <$> getContextSize) $ do         typeError $ GenericError $ "We don't like postulated sizes in parametrized modules."@@ -637,19 +631,25 @@     -- Set blocking tag to MissingClauses if we still expect clauses-  let blk = case funSig of-        A.FunSig{}   -> NotBlocked MissingClauses   ()-        A.NoFunSig{} -> NotBlocked ReallyNotBlocked ()+  let blk = case kind of+        FunName   -> NotBlocked MissingClauses   ()+        MacroName -> NotBlocked MissingClauses   ()+        _         -> NotBlocked ReallyNotBlocked ()    -- Not safe. See Issue 330   -- t <- addForcingAnnotations t++  let defn = defaultDefn info x t $+        case kind of   -- #4833: set abstract already here so it can be inherited by with functions+          FunName   -> emptyFunction{ funAbstr = Info.defAbstract i }+          MacroName -> set funMacro True emptyFunction{ funAbstr = Info.defAbstract i }+          DataName  -> DataOrRecSig npars+          RecName   -> DataOrRecSig npars+          AxiomName -> defaultAxiom     -- Old comment: NB: used also for data and record type sigs+          _         -> __IMPOSSIBLE__+   addConstant x =<< do-    useTerPragma $-      (defaultDefn info x t $-         case funSig of-           A.FunSig   -> set funMacro (Info.defMacro i == MacroDef) emptyFunction-           A.NoFunSig | isJust gentel -> DataOrRecSig npars-           A.NoFunSig -> Axiom)   -- NB: used also for data and record type sigs+    useTerPragma $ defn         { defArgOccurrences    = occs         , defPolarity          = pols         , defGeneralizedParams = genParams@@ -670,8 +670,8 @@     solveSizeConstraints $ if checkingWhere then DontDefaultToInfty else DefaultToInfty  -- | Type check a primitive function declaration.-checkPrimitive :: A.DefInfo -> QName -> A.Expr -> TCM ()-checkPrimitive i x e =+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     -- Certain "primitive" functions are BUILTIN rather than@@ -688,14 +688,27 @@           , "primLevelSuc"           , "primLevelMax"           , "primSetOmega"+          , "primStrictSet"+          , "primStrictSetOmega"           ]-    when (name `elem` builtinPrimitives) $ typeError $ NoSuchPrimitiveFunction name+    when (name `elem` builtinPrimitives) $ do+      reportSDoc "tc.prim" 20 $ text name <+> "is a BUILTIN, not a primitive!"+      typeError $ NoSuchPrimitiveFunction name     t <- isType_ e     noConstraints $ equalType t t'     let s  = prettyShow $ qnameName x+    -- Checking the modality. Currently all primitives require default+    -- modalities, and likely very few will have different modalities in the+    -- future. Thus, rather than, the arguably nicer solution of adding a+    -- modality to PrimImpl we simply check the few special primitives here.+    let expectedInfo =+          case name of+            -- Currently no special primitives+            _ -> defaultArgInfo+    unless (info == expectedInfo) $ typeError $ WrongModalityForPrimitive name info expectedInfo     bindPrimitive s pf     addConstant x $-      defaultDefn defaultArgInfo x t $+      defaultDefn info x t $         Primitive { primAbstr    = Info.defAbstract i                   , primName     = s                   , primClauses  = []@@ -706,8 +719,11 @@ checkPragma :: Range -> A.Pragma -> TCM () checkPragma r p =     traceCall (CheckPragma r p) $ case p of-        A.BuiltinPragma x e -> bindBuiltin (rangedThing x) e-        A.BuiltinNoDefPragma b x -> bindBuiltinNoDef (rangedThing b) x+        A.BuiltinPragma rb x+          | isUntypedBuiltin b -> return ()+          | otherwise          -> bindBuiltin b x+          where b = rangedThing rb+        A.BuiltinNoDefPragma b _kind x -> bindBuiltinNoDef (rangedThing b) x         A.RewritePragma _ qs -> addRewriteRules qs         A.CompilePragma b x s -> do           -- Check that x resides in the same module (or a child) as the pragma.@@ -736,8 +752,9 @@           caseMaybeM (isRecord r) noRecord $ \case             Record{ recInduction = ind, recEtaEquality' = eta } -> do               unless (ind == Just CoInductive) $ noRecord-              when (eta == Specified NoEta) $ typeError $ GenericError $-                "ETA pragma conflicts with no-eta-equality declaration"+              if | Specified NoEta{} <- eta -> typeError $ GenericError $+                     "ETA pragma conflicts with no-eta-equality declaration"+                 | otherwise -> return ()             _ -> __IMPOSSIBLE__           modifySignature $ updateDefinition r $ updateTheDef $ \case             def@Record{} -> def { recEtaEquality' = Specified YesEta }@@ -774,8 +791,9 @@   Bench.billTo [Bench.Typing, Bench.TypeSig] $     let abstr = case Info.defAccess i of           PrivateAccess{}-            | Info.defAbstract i == AbstractDef -> inAbstractMode+            | Info.defAbstract i == AbstractDef -> inConcreteMode               -- Issue #2321, only go to AbstractMode for abstract definitions+              -- 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@@ -785,8 +803,8 @@  -- | Type check a module. -checkSection :: Info.ModuleInfo -> ModuleName -> A.GeneralizeTelescope -> [A.Declaration] -> TCM ()-checkSection _ x tel ds = newSection x tel $ mapM_ checkDeclCached ds+checkSection :: ModuleName -> A.GeneralizeTelescope -> [A.Declaration] -> TCM ()+checkSection x tel ds = newSection x tel $ mapM_ checkDeclCached ds   -- | Helper for 'checkSectionApplication'.@@ -830,7 +848,7 @@         (NotHidden, Hidden, _)            -> bad         (NotHidden, Instance{}, _)        -> bad --- | Check an application of a section (top-level function, includes @'traceCall'@).+-- | Check an application of a section. checkSectionApplication   :: Info.ModuleInfo   -> ModuleName          -- ^ Name @m1@ of module defined by the module macro.@@ -839,9 +857,13 @@   -> TCM () checkSectionApplication i m1 modapp copyInfo =   traceCall (CheckSectionApplication (getRange i) m1 modapp) $+  -- A section application is type-checked in a non-erased context+  -- (#5410).+  localTC (over eQuantity $ mapQuantity (`addQuantity` topQuantity)) $   checkSectionApplication' i m1 modapp copyInfo --- | Check an application of a section.+-- | Check an application of a section. (Do not invoke this procedure+-- directly, use 'checkSectionApplication'.) checkSectionApplication'   :: Info.ModuleInfo   -> ModuleName          -- ^ Name @m1@ of module defined by the module macro.@@ -883,14 +905,14 @@     reportSDoc "tc.mod.apply" 15 $ vcat       [ "applying section" <+> prettyTCM m2       , nest 2 $ "args =" <+> sep (map prettyA args)-      , nest 2 $ "ptel =" <+> escapeContext __IMPOSSIBLE__ (size ptel) (prettyTCM ptel)+      , nest 2 $ "ptel =" <+> escapeContext impossible (size ptel) (prettyTCM ptel)       , nest 2 $ "tel  =" <+> prettyTCM tel       , nest 2 $ "tel' =" <+> prettyTCM tel'       , nest 2 $ "tel''=" <+> prettyTCM tel''-      , nest 2 $ "eta  =" <+> escapeContext __IMPOSSIBLE__ (size ptel) (addContext tel'' $ prettyTCM etaTel)+      , nest 2 $ "eta  =" <+> escapeContext impossible (size ptel) (addContext tel'' $ prettyTCM etaTel)       ]     -- Now, type check arguments.-    ts <- (noConstraints $ checkArguments_ DontExpandLast (getRange i) args tel') >>= \case+    ts <- noConstraints (checkArguments_ CmpEq DontExpandLast (getRange i) args tel') >>= \case       (ts', etaTel') | (size etaTel == size etaTel')                      , Just ts <- allApplyElims ts' -> return ts       _ -> __IMPOSSIBLE__

src/full/Agda/TypeChecking/Rules/Def.hs view

@@ -2,19 +2,18 @@  module Agda.TypeChecking.Rules.Def where -import Prelude hiding ( mapM, null )+import Prelude hiding ( null ) -import Control.Arrow (first,second)-import Control.Monad.State hiding (forM, mapM)+import Control.Monad.Except+import Control.Monad.State +import Data.Bifunctor import Data.Function import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Maybe-import Data.Traversable (forM, mapM) import Data.Semigroup (Semigroup((<>)))-import Data.Tuple ( swap )  import Agda.Interaction.Options @@ -26,14 +25,13 @@ import qualified Agda.Syntax.Abstract.Views as A import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern as I+import Agda.Syntax.Internal.MetaVars (allMetasList) import qualified Agda.Syntax.Info as Info-import Agda.Syntax.Fixity-import Agda.Syntax.Info+import Agda.Syntax.Info hiding (defAbstract)  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Warnings ( warning )+import Agda.TypeChecking.Warnings ( warning, genericWarning )  import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion@@ -46,6 +44,7 @@ import Agda.TypeChecking.CheckInternal import Agda.TypeChecking.With import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Injectivity import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.SizedTypes.Solve@@ -53,15 +52,17 @@ import Agda.TypeChecking.CompiledClause (CompiledClauses'(..), hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Sort  import Agda.TypeChecking.Rules.Term import Agda.TypeChecking.Rules.LHS                 ( checkLeftHandSide, LHSResult(..), bindAsPatterns ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls ) -import Agda.Utils.Except ( MonadError(catchError) ) 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.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -69,6 +70,7 @@ import Agda.Utils.Pretty ( prettyShow ) import qualified Agda.Utils.Pretty as P import Agda.Utils.Size+import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible @@ -85,29 +87,39 @@         def <- instantiateDef =<< getConstInfo name         let t    = defType def         let info = getArgInfo def-        case isAlias cs t of-          Just (e, mc, x) ->-            traceCall (CheckFunDefCall (getRange i) name cs) $ 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.-              whenM (isFrozen x) $ unfreezeMeta x-              checkAlias t info delayed i name e mc+        case isAlias cs t of  -- #418: Don't use checkAlias for abstract definitions, since the type+                              -- of an abstract function must not be informed by its definition.+          Just (e, mc, x)+            | Info.defAbstract i /= AbstractDef ->+              traceCall (CheckFunDefCall (getRange i) name cs 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.+                -- Ulf, 2021-02-09: also unfreeze metas in the sort of this type+                whenM (isFrozen x) $ do+                  xs <- allMetasList . jMetaType . mvJudgement <$> lookupMeta x+                  mapM_ unfreezeMeta (x : xs)+                checkAlias t info delayed i name e mc+            | otherwise -> do -- Warn about abstract alias (will never work!)+              setCurrentRange i $ genericWarning =<<+                "Missing type signature for abstract definition" <+> (prettyTCM name <> ".") $$+                fsep (pwords "Types of abstract definitions are never inferred since this would leak" +++                      pwords "information that should be abstract.")+              checkFunDef' t info delayed Nothing Nothing i name cs           _ -> checkFunDef' t info delayed Nothing Nothing i name cs          -- If it's a macro check that it ends in Term → TC ⊤         let ismacro = isMacro . theDef $ def         when (ismacro || Info.defMacro i == MacroDef) $ checkMacroType t-    `catchIlltypedPatternBlockedOnMeta` \ (err, x) -> do+    `catchIlltypedPatternBlockedOnMeta` \ (err, blocker) -> do         reportSDoc "tc.def" 20 $ vcat $-          [ "checking function definition got stuck on meta: " <+> text (show x) ]-        modifySignature $ updateDefinition name $ updateDefBlocked $ const $ Blocked x ()-        addConstraint $ CheckFunDef delayed i name cs+          [ "checking function definition got stuck on: " <+> pretty blocker ]+        modifySignature $ updateDefinition name $ updateDefBlocked $ const $ Blocked blocker ()+        addConstraint blocker $ CheckFunDef delayed i name cs err  checkMacroType :: Type -> TCM () checkMacroType t = do-  t' <- normalise t-  TelV tel tr <- telView t'+  TelV tel tr <- telView t    let telList = telToList tel       resType = abstract (telFromList (drop (length telList - 1) telList)) tr@@ -128,7 +140,8 @@   where     isMeta (MetaV x _) = Just x     isMeta _           = Nothing-    trivialClause [A.Clause (A.LHS i (A.LHSHead f [])) _ (A.RHS e mc) (A.WhereDecls _ []) _] = Just (e, mc)+    trivialClause [A.Clause (A.LHS i (A.LHSHead f [])) _ (A.RHS e mc) wh _]+      | null wh     = Just (e, mc)     trivialClause _ = Nothing  -- | Check a trivial definition of the form @f = e@@@ -176,6 +189,7 @@                           , clauseBody      = Just $ bodyMod v                           , clauseType      = Just $ Arg ai t                           , clauseCatchall  = False+                          , clauseExact     = Just True                           , clauseRecursive = Nothing   -- we don't know yet                           , clauseUnreachable = Just False                           , clauseEllipsis = NoEllipsis@@ -225,7 +239,7 @@              -> TCM () checkFunDefS t ai delayed extlam with i name withSub cs = do -    traceCall (CheckFunDefCall (getRange i) name cs) $ do+    traceCall (CheckFunDefCall (getRange i) name cs True) $ do         reportSDoc "tc.def.fun" 10 $           sep [ "checking body of" <+> prettyTCM name               , nest 2 $ ":" <+> prettyTCM t@@ -233,12 +247,12 @@               ]          reportSDoc "tc.def.fun" 70 $-          sep $ [ "clauses:" ] ++ map (nest 2 . text . show . A.deepUnscope) cs+          sep $ "clauses:" : map (nest 2 . text . show . A.deepUnscope) cs          cs <- return $ map A.lhsToSpine cs          reportSDoc "tc.def.fun" 70 $-          sep $ [ "spine clauses:" ] ++ map (nest 2 . text . show . A.deepUnscope) cs+          sep $ "spine clauses:" : map (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.@@ -271,7 +285,7 @@         canBeSystem <- do           -- allow VarP and ConP i0/i1 fallThrough = yes, DotP           let pss = map namedClausePats cs-              allowed p = case p of+              allowed = \case                 VarP{} -> True                 -- pattern inserted by splitPartial                 ConP _ cpi [] | conPFallThrough cpi -> True@@ -283,7 +297,7 @@           reportSDoc "tc.def.fun" 70 $ inTopContext $ do-          sep $ [ "checked clauses:" ] ++ map (nest 2 . text . show) cs+          sep $ "checked clauses:" : map (nest 2 . text . show) cs          -- After checking, remove the clauses again.         -- (Otherwise, @checkInjectivity@ loops for issue 801).@@ -317,6 +331,7 @@                        , clauseBody = Nothing                        , clauseType = Just (defaultArg t)                        , clauseCatchall = False+                       , clauseExact     = Just True                        , clauseRecursive = Just False                        , clauseUnreachable = Just False                        , clauseEllipsis = NoEllipsis@@ -385,13 +400,6 @@          covering <- funCovering . theDef <$> getConstInfo name -        -- Jesper, 2019-05-30: if the constructors used in the-        -- lhs of a clause have rewrite rules, we need to check-        -- confluence here-        whenM (optConfluenceCheck <$> pragmaOptions) $ inTopContext $-          forM_ (zip cs [0..]) $ \(c , clauseNo) ->-            checkConfluenceOfClause name clauseNo c-         -- Add the definition         inTopContext $ addConstant name =<< do           -- If there was a pragma for this definition, we can set the@@ -418,6 +426,12 @@               , nest 2 $ prettyTCM . defType =<< getConstInfo name               ] +        -- Jesper, 2019-05-30: if the constructors used in the+        -- lhs of a clause have rewrite rules, we need to check+        -- confluence here+        whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> inTopContext $+          checkConfluenceOfClauses confChk name+ -- | Set 'funTerminates' according to termination info in 'TCEnv', --   which comes from a possible termination pragma. useTerPragma :: Definition -> TCM Definition@@ -434,20 +448,52 @@   return $ def { theDef = fun { funTerminates = terminates }} useTerPragma def = return def --- | Insert some with-patterns into the with-clauses LHS of the given RHS.--- (Used for @rewrite@.)-insertPatterns :: [A.Pattern] -> A.RHS -> A.RHS-insertPatterns pats = \case+-- | Modify all the LHSCore of the given RHS.+-- (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 (insertPatternsLHSCore pats core)) spats (insertPatterns pats rhs) ds catchall-  A.RewriteRHS qes spats rhs wh -> A.RewriteRHS qes spats (insertPatterns pats rhs) wh+    \ (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 +-- | Insert some names into the with-clauses LHS of the given RHS.+-- (Used for the inspect idiom)+insertNames :: [Arg (Maybe A.BindName)] -> A.RHS -> A.RHS+insertNames = mapLHSCores . insertInspects++insertInspects :: [Arg (Maybe A.BindName)] -> A.LHSCore -> A.LHSCore+insertInspects ps = \case+  A.LHSWith core wps [] ->+    let ps' = map (fmap $ fmap patOfName) ps in+    A.LHSWith core (insertIn ps' wps) []+  _ -> __IMPOSSIBLE__++  where++    patOfName :: A.BindName -> Arg A.Pattern+    patOfName = defaultArg . A.VarP++    insertIn :: [Arg (Maybe (Arg a))]+             -> [Arg a] -> [Arg a]+    insertIn []                 wps  = wps+    insertIn (Arg info nm : ps) (w : wps) | visible info =+      w : (maybe [] pure nm) ++ insertIn ps wps+    insertIn (Arg info nm : ps) wps       | notVisible info =+          (maybe [] pure nm) ++ insertIn ps wps+    insertIn _ _ = __IMPOSSIBLE__+++-- | Insert some with-patterns into the with-clauses LHS of the given RHS.+-- (Used for @rewrite@)+insertPatterns :: [Arg A.Pattern] -> A.RHS -> A.RHS+insertPatterns pats = mapLHSCores (insertPatternsLHSCore pats)+ -- | Insert with-patterns before the trailing with patterns. -- If there are none, append the with-patterns.-insertPatternsLHSCore :: [A.Pattern] -> A.LHSCore -> A.LHSCore+insertPatternsLHSCore :: [Arg A.Pattern] -> A.LHSCore -> A.LHSCore insertPatternsLHSCore pats = \case   A.LHSWith core wps [] -> A.LHSWith core (pats ++ wps) []   core                  -> A.LHSWith core pats []@@ -462,7 +508,7 @@     , wfParentTel  :: Telescope                         -- ^ Context of the parent patterns.     , wfBeforeTel  :: Telescope                         -- ^ Types of arguments to the with function before the with expressions (needed vars).     , wfAfterTel   :: Telescope                         -- ^ Types of arguments to the with function after the with expressions (unneeded vars).-    , wfExprs      :: [WithHiding (Term, EqualityView)] -- ^ With and rewrite expressions and their types.+    , wfExprs      :: [Arg (Term, EqualityView)]        -- ^ With and rewrite expressions and their types.     , wfRHSType    :: Type                              -- ^ Type of the right hand side.     , wfParentPats :: [NamedArg DeBruijnPattern]        -- ^ Parent patterns.     , wfParentParams :: Nat                             -- ^ Number of module parameters in parent patterns@@ -470,6 +516,7 @@     , wfPermParent :: Permutation                       -- ^ Permutation reordering the variables in the parent pattern.     , wfPermFinal  :: Permutation                       -- ^ Final permutation (including permutation for the parent clause).     , wfClauses    :: [A.Clause]                        -- ^ The given clauses for the with function+    , wfCallSubst :: Substitution                       -- ^ Subtsitution to generate call for the parent.     }  checkSystemCoverage@@ -523,18 +570,17 @@         alphas :: [[(Int,Bool)]] -- the face maps corresponding to each clause         alphas = map (collectDirs (downFrom n)) pats         phis :: [Term] -- the φ terms for each clause (i.e. the alphas as terms)-        phis = map andI $ map (map dir) alphas+        phis = map (andI . (map dir)) alphas         psi = orI $ phis         pcs = zip phis cs-        boolToI True = i1-        boolToI False = i0        reportSDoc "tc.sys.cover" 20 $ fsep $ map prettyTCM pats-      interval <- elInf primInterval+      interval <- primIntervalType       reportSDoc "tc.sys.cover" 10 $ "equalTerm " <+> prettyTCM (unArg phi) <+> prettyTCM psi       equalTerm interval (unArg phi) psi -      forM_ (init $ init $ List.tails pcs) $ \ ((phi1,cl1):pcs') -> do+      forM_ (initWithDefault __IMPOSSIBLE__ $+             initWithDefault __IMPOSSIBLE__ $ List.tails pcs) $ \ ((phi1,cl1):pcs') -> do         forM_ pcs' $ \ (phi2,cl2) -> do           phi12 <- reduce (imin `apply` [argN phi1, argN phi2])           forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \ sigma -> do@@ -602,7 +648,7 @@       typeError $ UnexpectedWithPatterns $ map namedArg withPats     traceCall (CheckClause t c) $ do       aps <- expandPatternSynonyms aps-      when (not $ null strippedPats) $ reportSDoc "tc.lhs.top" 50 $+      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) (Just x) aps t withSub strippedPats ret@@ -652,28 +698,30 @@         -- the context with the parent (but withSub will take you from parent         -- to child). -        unsafeInTopContext $ Bench.billTo [Bench.Typing, Bench.With] $ checkWithFunction cxtNames with+        wbody <- unsafeInTopContext $ Bench.billTo [Bench.Typing, Bench.With] $ checkWithFunction cxtNames with +        body <- return $ body `mplus` wbody+         whenM (optDoubleCheck <$> pragmaOptions) $ case body of           Just v  -> do             reportSDoc "tc.lhs.top" 30 $ vcat               [ "double checking rhs"               , nest 2 (prettyTCM v <+> " : " <+> prettyTCM (unArg trhs))               ]-            noConstraints $ dontAssignMetas $ checkInternal v CmpLeq $ unArg trhs+            nonConstraining $ checkInternal v CmpLeq $ unArg trhs           Nothing -> return ()          reportSDoc "tc.lhs.top" 10 $ vcat           [ "Clause before translation:"           , nest 2 $ vcat-            [ "delta =" <+> do escapeContext __IMPOSSIBLE__ (size delta) $ prettyTCM delta+            [ "delta =" <+> do escapeContext impossible (size 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" 60 $ escapeContext impossible (size delta) $ vcat           [ "Clause before translation (raw):"           , nest 2 $ vcat             [ "ps    =" <+> text (show ps)@@ -684,6 +732,7 @@          -- check naturality wrt the interval.         let+          -- TODO:: Defined but not used           iApplyVars :: [NamedArg DeBruijnPattern] -> [(Int, (Term,Term))]           iApplyVars ps = flip concatMap (map namedArg ps) $ \case                              IApplyP _ t u x -> [(dbPatVarIndex x,(t,u))]@@ -704,6 +753,9 @@         -- treat them as catchalls.         let catchall' = catchall || isNothing body +        -- absurd clauses are not exact+        let exact = if isNothing body then Just False else Nothing -- we don't know yet+         return $ (, CPC psplit)           Clause { clauseLHSRange  = getRange i                  , clauseFullRange = getRange c@@ -712,13 +764,28 @@                  , clauseBody      = bodyMod body                  , clauseType      = Just trhs                  , clauseCatchall  = catchall'+                 , clauseExact       = exact                  , clauseRecursive   = Nothing -- we don't know yet                  , clauseUnreachable = Nothing -- we don't know yet                  , clauseEllipsis  = lhsEllipsis i                  } --- | Type check the @with@ and @rewrite@ lhss and/or the rhs. ++-- | Generate the abstract pattern corresponding to Refl+getReflPattern :: TCM A.Pattern+getReflPattern = do+  -- Get the name of builtin REFL.+  Con reflCon _ [] <- primRefl++  reflInfo <- fmap (setOrigin Inserted) <$> getReflArgInfo reflCon+  let patInfo = ConPatInfo ConOCon patNoRange ConPatEager+  -- The REFL constructor might have an argument+  let reflArg = maybeToList $ fmap (\ ai -> Arg ai $ unnamed $ A.WildP patNoRange) reflInfo++  pure $ A.ConP patInfo (unambiguous $ conName reflCon) reflArg++-- | Type check the @with@ and @rewrite@ lhss and/or the rhs. checkRHS   :: LHSInfo                 -- ^ Range of lhs.   -> QName                   -- ^ Name of function.@@ -745,7 +812,9 @@     -- one we complain, ignore it and return the same @(Nothing, NoWithFunction)@     -- as the case dealing with @A.AbsurdRHS@.     mv <- if absurdPat-          then Nothing <$ setCurrentRange e (warning $ AbsurdPatternRequiresNoRHS ps)+          then do+            ps <- instantiateFull ps+            Nothing <$ setCurrentRange e (warning $ AbsurdPatternRequiresNoRHS ps)           else Just <$> checkExpr e (unArg trhs)     return (mv, NoWithFunction) @@ -755,18 +824,18 @@     unless absurdPat $ typeError $ NoRHSRequiresAbsurdPattern aps     return (Nothing, NoWithFunction) --  -- With case: @f xs with a | b | c | ...; ... | ps1 = rhs1; ... | ps2 = rhs2; ...@-  -- This is mostly a wrapper around @checkWithRHS@-  withRHS :: QName               -- ^ name of the with-function-          -> [WithHiding A.Expr] -- ^ @[a, b, c, ...]@-          -> [A.Clause]          -- ^ @[(ps1 = rhs1), (ps2 = rhs), ...]@+  -- With case: @f xs with {a} in eqa | b in eqb | {{c}} | ...; ... | ps1 = rhs1; ... | ps2 = rhs2; ...@+  -- We need to modify the patterns `ps1, ps2, ...` in the user-provided clauses+  -- to insert the {eqb} names so that the equality proofs are available on the various RHS.+  withRHS :: QName         -- name of the with-function+          -> [A.WithExpr]  -- @[{a} in eqa, b in eqb, {{c}}, ...]@+          -> [A.Clause]    -- @[(ps1 = rhs1), (ps2 = rhs), ...]@           -> TCM (Maybe Term, WithFunctionProblem)   withRHS aux es cs = do      reportSDoc "tc.with.top" 15 $ vcat       [ "TC.Rules.Def.checkclause reached A.WithRHS"-      , sep $ prettyA aux : map (parens . prettyA) es+      , sep $ prettyA aux : map (parens . prettyA . namedThing) es       ]     reportSDoc "tc.with.top" 20 $ do       nfv <- getCurrentModuleFreeVars@@ -777,8 +846,19 @@           ]      -- Infer the types of the with expressions-    vtys <- mapM (traverse (fmap OtherType <.> inferExprForWith)) es +    vtys <- forM es $ \ (Named nm we) -> do+              (e, ty) <- inferExprForWith we+              pure $ (<$ we) . (e,) $ case nm of+                Nothing -> OtherType ty+                Just{}  -> IdiomType ty++    let names = map (\ (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+     -- Andreas, 2016-01-23, Issue #1796     -- Run the size constraint solver to improve with-abstraction     -- in case the with-expression contains size metas.@@ -787,30 +867,43 @@     checkWithRHS x aux t lhsResult vtys cs    -- Rewrite case: f xs (rewrite / invert) a | b | c | ...-  rewriteEqnsRHS :: [A.RewriteEqn] -> [A.ProblemEq] -> A.RHS -> A.WhereDeclarations -> TCM (Maybe Term, WithFunctionProblem)+  rewriteEqnsRHS+    :: [A.RewriteEqn]+    -> [A.ProblemEq]+    -> A.RHS+    -> A.WhereDeclarations+    -> TCM (Maybe Term, WithFunctionProblem)+   rewriteEqnsRHS [] strippedPats rhs wh = checkWhere wh $ handleRHS rhs       -- Case: @rewrite@       -- Andreas, 2014-01-17, Issue 1402:       -- If the rewrites are discarded since lhs=rhs, then       -- we can actually have where clauses.   rewriteEqnsRHS (r:rs) strippedPats rhs wh = case r of-    Rewrite ((qname, eq) : qes) ->-      rewriteEqnRHS qname eq (case qes of { [] -> rs; _ -> Rewrite qes : rs })-    Invert _     []  -> __IMPOSSIBLE__-    Invert qname pes -> invertEqnRHS qname pes rs-    -- Invariant: these lists are non-empty-    Rewrite [] -> __IMPOSSIBLE__+    Rewrite ((qname, eq) :| qes) ->+      rewriteEqnRHS qname eq $+        List1.ifNull qes {-then-} rs {-else-} $ \ qes -> Rewrite qes : rs+    Invert qname pes -> invertEqnRHS qname (List1.toList pes) rs      where      -- @invert@ clauses-    invertEqnRHS :: QName -> [(A.Pattern,A.Expr)] -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)+    invertEqnRHS :: QName -> [Named A.BindName (A.Pattern,A.Expr)] -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)     invertEqnRHS qname pes rs = do -      let (pats, es) = unzip pes+      let (npats, es) = unzipWith (\ (Named nm (p , e)) -> (Named nm p, Named nm e)) pes       -- Infer the types of the with expressions-      vtys <- mapM (WithHiding NotHidden <.> fmap OtherType <.> inferExprForWith) es+      vtys <- forM es $ \ (Named nm we) -> do+        (e, ty) <- inferExprForWith (defaultArg we)+        pure $ defaultArg . (e,) $ case nm of+          Nothing -> OtherType ty+          Just{}  -> IdiomType ty +      let pats = concatMap (map defaultArg) $+            for npats $ \ (Named nm p) -> case nm of+              Nothing -> [p]+              Just n  -> [p, A.VarP n]+       -- Andreas, 2016-04-14, see also Issue #1796       -- Run the size constraint solver to improve with-abstraction       -- in case the with-expression contains size metas.@@ -832,8 +925,11 @@       checkWithRHS x qname t lhsResult vtys [cl]      -- @rewrite@ clauses-    rewriteEqnRHS :: QName -> A.Expr-                  -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)+    rewriteEqnRHS+      :: QName+      -> A.Expr+      -> [A.RewriteEqn]+      -> TCM (Maybe Term, WithFunctionProblem)     rewriteEqnRHS qname eq rs = do        -- Action for skipping this rewrite.@@ -842,6 +938,7 @@       -- Thus, we restore the state in this case,       -- unless the rewrite expression contains questionmarks.       st <- getTC+      -- TODO:: recurse defined but not used       let recurse = do            st' <- getTC            -- Comparing the whole stInteractionPoints maps is a bit@@ -868,36 +965,15 @@       t' <- reduce =<< instantiateFull eqt       (eqt,rewriteType,rewriteFrom,rewriteTo) <- equalityView t' >>= \case         eqt@(EqualityType _s _eq _params (Arg _ dom) a b) -> do-          s <- inferSort dom+          s <- sortOf dom           return (eqt, El s dom, unArg a, unArg b)           -- Note: the sort _s of the equality need not be the sort of the type @dom@!         OtherType{} -> typeError . GenericDocError =<< do           "Cannot rewrite by equation of type" <+> prettyTCM t'--      -- Get the name of builtin REFL.--      Con reflCon _ [] <- primRefl-      reflInfo <- fmap (setOrigin Inserted) <$> getReflArgInfo reflCon--      -- Andreas, 2017-01-11:-      -- The test for refl is obsolete after fixes of #520 and #1740.-      -- -- Andreas, 2014-05-17  Issue 1110:-      -- -- Rewriting with @refl@ has no effect, but gives an-      -- -- incomprehensible error message about the generated-      -- -- with clause. Thus, we rather do simply nothing if-      -- -- rewriting with @refl@ is attempted.-      -- let isReflProof = do-      --      v <- reduce proof-      --      case v of-      --        Con c _ [] | c == reflCon -> return True-      --        _ -> return False-      -- ifM isReflProof recurse $ {- else -} do--      -- Process 'rewrite' clause like a suitable 'with' clause.+        IdiomType{} -> typeError . GenericDocError =<< do+          "Cannot rewrite by equation of type" <+> prettyTCM t' -      -- The REFL constructor might have an argument-      let reflPat  = A.ConP (ConPatInfo ConOCon patNoRange ConPatEager) (unambiguous $ conName reflCon) $-            maybeToList $ fmap (\ ai -> Arg ai $ unnamed $ A.WildP patNoRange) reflInfo+      reflPat <- getReflPattern        -- Andreas, 2015-12-25  Issue #1740:       -- After the fix of #520, rewriting with a reflexive equation@@ -905,10 +981,11 @@       let isReflexive = tryConversion $ dontAssignMetas $            equalTerm rewriteType rewriteFrom rewriteTo -      (pats, withExpr, withType) <- do+      (pats', withExpr, withType) <- do         ifM isReflexive           {-then-} (return ([ reflPat ]                    , proof, OtherType t'))           {-else-} (return ([ A.WildP patNoRange, reflPat ], proof, eqt))+      let pats = defaultArg <$> pats'        let rhs' = insertPatterns pats rhs           (rhs'', outerWhere) -- the where clauses should go on the inner-most with@@ -923,31 +1000,31 @@         [ text "rewrite"         , "  rhs' = " <> (text . show) rhs'         ]-      checkWithRHS x qname t lhsResult [WithHiding NotHidden (withExpr, withType)] [cl]+      checkWithRHS x qname t lhsResult [defaultArg (withExpr, withType)] [cl]  checkWithRHS   :: QName                             -- ^ Name of function.   -> QName                             -- ^ Name of the with-function.   -> Type                              -- ^ Type of function.   -> LHSResult                         -- ^ Result of type-checking patterns-  -> [WithHiding (Term, EqualityView)] -- ^ Expressions and types of with-expressions.+  -> [Arg (Term, EqualityView)]        -- ^ Expressions and types of with-expressions.   -> [A.Clause]                        -- ^ With-clauses to check.   -> TCM (Maybe Term, WithFunctionProblem)                                 -- Note: as-bindings already bound (in checkClause) checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _) vtys0 cs =   Bench.billTo [Bench.Typing, Bench.With] $ do-        let withArgs = withArguments vtys0-            perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm ps+        withArgs <- withArguments vtys0+        let perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm ps         vtys0 <- normalise vtys0          -- 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 $ escapeContext impossible (size delta) $ vcat           [ "delta  =" <+> prettyTCM delta           ]         reportSDoc "tc.with.top" 25 $ vcat $           -- declared locally because we do not want to use the unzip'd thing!-          let (vs, as) = unzipWith whThing vtys0 in+          let (vs, as) = unzipWith unArg vtys0 in           [ "vs     =" <+> prettyTCM vs           , "as     =" <+> prettyTCM as           , "perm   =" <+> text (show perm)@@ -962,7 +1039,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 $ escapeContext impossible (size delta) $ vcat           [ "delta1 =" <+> prettyTCM delta1           , "delta2 =" <+> addContext delta1 (prettyTCM delta2)           ]@@ -974,7 +1051,7 @@         -- Create the body of the original function          -- All the context variables-        us <- getContextArgs+        us <- getContextTerms         let n = size us             m = size delta             -- First the variables bound outside this definition@@ -982,42 +1059,39 @@             -- Then permute the rest and grab those needed to for the with arguments             (us1, us2)  = splitAt (size delta1) $ permute perm' us1'             -- Now stuff the with arguments in between and finish with the remaining variables-            mkWithArg = \ (WithHiding h e) -> setHiding h $ defaultArg e-            v         = Def aux $ map Apply $ us0 ++ us1 ++ map mkWithArg withArgs ++ us2+            argsS = parallelS $ reverse $ us0 ++ us1 ++ map unArg withArgs ++ us2+            v         = Nothing -- generated by checkWithFunction         -- Andreas, 2013-02-26 add with-name to signature for printing purposes         addConstant aux =<< do           useTerPragma $ defaultDefn defaultArgInfo aux __DUMMY_TYPE__ emptyFunction -        -- Andreas, 2013-02-26 separate msgs to see which goes wrong         reportSDoc "tc.with.top" 20 $ vcat $-          let (vs, as) = unzipWith whThing vtys in-          [ "    with arguments" <+> do escapeContext __IMPOSSIBLE__ (size delta) $ addContext delta1 $ prettyList (map prettyTCM vs)-          , "             types" <+> do escapeContext __IMPOSSIBLE__ (size delta) $ addContext delta1 $ prettyList (map prettyTCM as)-          , "with function call" <+> prettyTCM v+          let (vs, as) = unzipWith unArg vtys in+          [ "    with arguments" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyList (map prettyTCM vs)+          , "             types" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyList (map 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-          , "              body" <+> prettyTCM v+          , "             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           ] -        return (Just v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs)+        return (v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS)  -- | Invoked in empty context.-checkWithFunction :: [Name] -> WithFunctionProblem -> TCM ()-checkWithFunction _ NoWithFunction = return ()-checkWithFunction cxtNames (WithFunction f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs) = do+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) = do    let -- Δ₁ ws Δ₂ ⊢ withSub : Δ′    (where Δ′ is the context of the parent lhs)       withSub :: Substitution-      withSub = let as = map (snd . whThing) vtys in+      withSub = let as = map (snd . unArg) vtys in                 liftS (size delta2) (wkS (countWithArgs as) idS)-                `composeS` renaming __IMPOSSIBLE__ (reverseP perm')+                `composeS` renaming impossible (reverseP perm')    reportSDoc "tc.with.top" 10 $ vcat     [ "checkWithFunction"     , nest 2 $ vcat $-      let (vs, as) = unzipWith whThing vtys in+      let (vs, as) = unzipWith unArg vtys in       [ "delta1 =" <+> prettyTCM delta1       , "delta2 =" <+> addContext delta1 (prettyTCM delta2)       , "t      =" <+> prettyTCM t@@ -1034,15 +1108,35 @@    -- Add the type of the auxiliary function to the signature +  -- Jesper, 2020-04-05: Currently variable generalization inserts+  -- dummy terms, we have to reduce projections to get rid of them.+  -- (see also #1332).+  let reds = SmallSet.fromList [ProjectionReductions]+  delta1 <- modifyAllowedReductions (const reds) $ normalise delta1+   -- Generate the type of the with function-  delta1 <- normalise delta1 -- Issue 1332: checkInternal is picky about argInfo-                             -- but module application is sloppy.-                             -- We normalise to get rid of Def's coming-                             -- from module applications.-  (withFunType, n) <- withFunctionType delta1 vtys delta2 b+  (withFunType, n) <- do+    let ps = renaming impossible (reverseP perm') `applySubst` qs+    reportSDoc "tc.with.bndry" 40 $ addContext delta1 $ addContext delta2+                                  $ text "ps =" <+> pretty ps+    let vs = iApplyVars ps+    bndry <- if null vs then return [] else do+      iz <- primIZero+      io <- primIOne+      let tm = Def f (patternsToElims ps)+      return [(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   reportSDoc "tc.with.type" 10 $ sep [ "with-function type:", nest 2 $ prettyTCM withFunType ]   reportSDoc "tc.with.type" 50 $ sep [ "with-function type:", nest 2 $ pretty withFunType ] +  call_in_parent <- do+    (TelV tel _,bs) <- telViewUpToPathBoundaryP (n + size delta) withFunType+    return $ argsS `applySubst` Def aux (teleElims tel bs)++  reportSDoc "tc.with.top" 20 $ addContext delta $ "with function call" <+> prettyTCM call_in_parent+   -- Andreas, 2013-10-21   -- Check generated type directly in internal syntax.   setCurrentRange cs $@@ -1082,11 +1176,13 @@   cs <- buildWithFunction cxtNames f aux t delta qs npars withSub finalPerm (size delta1) n cs   cs <- return $ map (A.spineToLhs) cs +  -- #4833: inherit abstract mode from parent+  abstr <- defAbstract <$> ignoreAbstractMode (getConstInfo f)+   -- Check the with function+  let info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess abstr (getRange cs)   checkFunDefS withFunType defaultArgInfo NotDelayed Nothing (Just f) info aux (Just withSub) cs--  where-    info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess ConcreteDef (getRange cs)+  return $ Just $ call_in_parent  -- | Type check a where clause. checkWhere@@ -1097,10 +1193,10 @@   ensureNoNamedWhereInRefinedContext whmod   loop ds   where-    loop ds = case ds of-      [] -> ret-      [A.ScopedDecl scope ds] -> withScope_ scope $ loop ds-      [A.Section _ m tel ds]  -> newSection m tel $ do+    loop = \case+      Nothing -> ret+      -- [A.ScopedDecl scope ds] -> withScope_ scope $ loop ds  -- IMPOSSIBLE+      Just (A.Section _ m tel ds) -> newSection m tel $ do           localTC (\ e -> e { envCheckingWhere = True }) $ do             checkDecls ds             ret@@ -1119,7 +1215,7 @@             [ 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.")             , text $ "In this case the module parameter" ++-                     (if length args > 0 then "s have" else " has") +++                     (if not (null args) then "s have" else " has") ++                      " been refined to"             , nest 2 $ vcat (zipWith pr names args) ]       where

src/full/Agda/TypeChecking/Rules/Display.hs view

@@ -1,8 +1,8 @@  module Agda.TypeChecking.Rules.Display (checkDisplayPragma) where -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty+import Control.Monad.State import Data.Maybe  import qualified Agda.Syntax.Abstract as A@@ -15,16 +15,20 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Pretty +import Agda.Utils.Pretty (prettyShow)+ import Agda.Utils.Impossible  checkDisplayPragma :: QName -> [NamedArg A.Pattern] -> A.Expr -> TCM () checkDisplayPragma f ps e = do   df <- inTopContext $ do-          pappToTerm f id ps $ \n args -> do-            let lhs = map I.Apply args+          pappToTerm f id ps $ \ n args -> do+            -- pappToTerm puts Var 0 for every variable. We get to know how many there were (n) so+            -- now we can renumber them with decreasing deBruijn indices.+            let lhs = renumberElims (n - 1) $ map I.Apply args             v <- exprToTerm e             return $ Display n lhs (DTerm v)-  reportSLn "tc.display.pragma" 20 $ "Adding display form for " ++ show f ++ "\n  " ++ show df+  reportSLn "tc.display.pragma" 20 $ "Adding display form for " ++ prettyShow f ++ "\n  " ++ show df   addDisplayForm f df  --UNUSED Liang-Ting 2019-07-16@@ -33,6 +37,8 @@ --displayLHS :: Telescope -> [NamedArg A.Pattern] -> (Int -> [Term] -> TCM a) -> TCM a --displayLHS tel ps ret = patternsToTerms tel ps $ \n vs -> ret n (map unArg vs) +type ToTm = StateT Nat TCM+ patternsToTerms :: Telescope -> [NamedArg A.Pattern] -> (Int -> Args -> TCM a) -> TCM a patternsToTerms _ [] ret = ret 0 [] patternsToTerms EmptyTel (p : ps) ret =@@ -63,14 +69,14 @@             | i > 0 -> i - 1           _ -> 0 -  patternsToTerms (dropTel pars tel) ps $ \n vs -> ret n (f vs)+  patternsToTerms (dropTel pars tel) ps $ \ n vs -> ret n (f vs)  patternToTerm :: A.Pattern -> (Nat -> Term -> TCM a) -> TCM a patternToTerm p ret =   case p of     A.VarP A.BindName{unBind = x}   -> bindVar x $ ret 1 (Var 0 [])     A.ConP _ cs ps-      | Just c <- getUnambiguous cs -> pappToTerm c (Con (ConHead c Inductive []) ConOCon . map Apply) ps ret+      | Just c <- getUnambiguous cs -> pappToTerm c (Con (ConHead c IsData Inductive []) ConOCon . map Apply) ps ret       | otherwise                   -> ambigErr "constructor" cs     A.ProjP _ _ ds       | Just d <- getUnambiguous ds -> ret 0 (Def d [])@@ -78,16 +84,14 @@     A.DefP _ fs ps       | Just f <- getUnambiguous fs -> pappToTerm f (Def f . map Apply) ps ret       | otherwise                   -> ambigErr "DefP" fs-    A.LitP l                        -> ret 0 (Lit l)+    A.LitP _ l                      -> ret 0 $ Lit l     A.WildP _                       -> bindWild $ ret 1 (Var 0 [])-    _                               -> do-      doc <- prettyA p-      typeError $ GenericError $ "Pattern not allowed in DISPLAY pragma:\n" ++ show doc+    _ -> genericDocError =<< vcat [ "Pattern not allowed in DISPLAY pragma:", prettyA p ]   where     ambigErr thing (AmbQ xs) =       genericDocError =<< do         text ("Ambiguous " ++ thing ++ ":") <?>-          fsep (punctuate comma (map pshow $ NonEmpty.toList xs))+          fsep (punctuate comma (fmap pretty xs))  bindWild :: TCM a -> TCM a bindWild ret = do@@ -102,8 +106,8 @@   case unScope e of     A.Var x  -> fst <$> getVarInfo x     A.Def f  -> pure $ Def f []-    A.Con c  -> pure $ Con (ConHead (headAmbQ c) Inductive []) ConOCon [] -- Don't care too much about ambiguity here-    A.Lit l  -> pure $ Lit l+    A.Con c  -> pure $ Con (ConHead (headAmbQ c) IsData Inductive []) ConOCon [] -- Don't care too much about ambiguity here+    A.Lit _ l  -> pure $ Lit l     A.App _ e arg  -> apply <$> exprToTerm e <*> ((:[]) . inheritHiding arg <$> exprToTerm (namedArg arg))      A.Proj _ f -> pure $ Def (headAmbQ f) []   -- only for printing so we don't have to worry too much here@@ -119,3 +123,19 @@     _                -> typeError $ GenericError $ "TODO: exprToTerm " ++ show e   where     notAllowed s = typeError $ GenericError $ "Not allowed in DISPLAY pragma right-hand side: " ++ s++renumberElims :: Nat -> Elims -> Elims+renumberElims n es = evalState (renumbers es) n+  where+    next :: State Nat Nat+    next = do i <- get; i <$ put (i - 1)++    renumbers :: Elims -> State Nat Elims+    renumbers = (traverse . traverse) renumber++    renumber :: Term -> State Nat Term+    renumber (Var 0 [])   = var <$> next+    renumber (Def f es)   = Def f <$> renumbers es+    renumber (Con c h es) = Con c h <$> renumbers es+    renumber (Lit l)      = pure $ Lit l+    renumber _            = __IMPOSSIBLE__ -- We need only handle the result of patternToTerm here

src/full/Agda/TypeChecking/Rules/LHS.hs view

@@ -5,41 +5,38 @@   , LHSResult(..)   , bindAsPatterns   , IsFlexiblePattern(..)+  , DataOrRecord(..)   , checkSortOfSplitVar   ) where -import Prelude hiding ( mapM, null, sequence )+import Prelude hiding ( null ) +import Data.Function (on) import Data.Maybe -import Control.Arrow (left)+import Control.Arrow (left, second) import Control.Monad+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Writer hiding ((<>)) import Control.Monad.Trans.Maybe -import Data.Either (partitionEithers)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.List (findIndex) import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Monoid ( Monoid, mempty, mappend ) import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup import Data.Map (Map) import qualified Data.Map as Map -import Agda.Interaction.Highlighting.Generate (storeDisambiguatedName, disambiguateRecordFields)+import Agda.Interaction.Highlighting.Generate+  ( storeDisambiguatedConstructor, storeDisambiguatedProjection, disambiguateRecordFields) import Agda.Interaction.Options import Agda.Interaction.Options.Lenses -import Agda.Syntax.Internal as I+import Agda.Syntax.Internal as I hiding (DataOrRecord(..)) import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Abstract (IsProjP(..)) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views (asView, deepUnscope) import Agda.Syntax.Concrete (FieldAssignment'(..),LensInScope(..))@@ -62,28 +59,30 @@ -- We can't explicitly hide just the constructor here because it isn't in the -- hs-boot file. import {-# SOURCE #-} Agda.TypeChecking.Empty (ensureEmptyType)-import Agda.TypeChecking.Forcing import Agda.TypeChecking.Patterns.Abstract import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records hiding (getRecordConstructor) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Primitive hiding (Nat)-import Agda.TypeChecking.Monad.Builtin -import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr)+import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr, isType_) import Agda.TypeChecking.Rules.LHS.Problem import Agda.TypeChecking.Rules.LHS.ProblemRest import Agda.TypeChecking.Rules.LHS.Unify import Agda.TypeChecking.Rules.LHS.Implicit import Agda.TypeChecking.Rules.Data -import Agda.Utils.Except (MonadError(..), ExceptT, runExceptT)+import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack ) 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.List  as List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -93,6 +92,7 @@ import Agda.Utils.Tuple  import Agda.Utils.Impossible+ --UNUSED Liang-Ting Chen 2019-07-16 ---- | Compute the set of flexible patterns in a list of patterns. The result is ----   the deBruijn indices of the flexible patterns.@@ -104,9 +104,9 @@ -- | A pattern is flexible if it is dotted or implicit, or a record pattern --   with only flexible subpatterns. class IsFlexiblePattern a where-  maybeFlexiblePattern :: a -> MaybeT TCM FlexibleVarKind+  maybeFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> MaybeT m FlexibleVarKind -  isFlexiblePattern :: a -> TCM Bool+  isFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> m Bool   isFlexiblePattern p =     maybe False notOtherFlex <$> runMaybeT (maybeFlexiblePattern p)     where@@ -129,6 +129,7 @@         ifM (isNothing <$> isRecordConstructor c) (return OtherFlex) {-else-}             (maybeFlexiblePattern qs)       A.LitP{}  -> return OtherFlex+      A.AnnP _ _ p -> maybeFlexiblePattern p       _ -> mzero  instance IsFlexiblePattern (I.Pattern' a) where@@ -197,6 +198,10 @@     update eq@(ProblemEq p@(A.AsP info x p') v a) =       (ProblemEq (A.VarP x) v a :) <$> update (ProblemEq p' v a) +    update eq@(ProblemEq p@(A.AnnP _ _ A.WildP{}) v a) = return [eq]+    update eq@(ProblemEq p@(A.AnnP info ty p') v a) =+      (ProblemEq (A.AnnP info ty (A.WildP patNoRange)) v a :) <$> update (ProblemEq p' v a)+     update eq@(ProblemEq p v a) = reduce v >>= constructorForm >>= \case       Con c ci es -> do         let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -204,11 +209,17 @@         contype <- getFullyAppliedConType c =<< reduce (unDom a)         caseMaybe contype (return [eq]) $ \((d,_,pars),b) -> do         TelV ctel _ <- telViewPath b++        -- Andrea 15/10/2020: propagate modality to constructor arguments+        let updMod = composeModality (getModality a)+        ctel <- return $ mapModality updMod <$> ctel+         let bs = instTel ctel (map unArg vs)          p <- expandLitPattern p         case p of           A.AsP{} -> __IMPOSSIBLE__+          A.AnnP{} -> __IMPOSSIBLE__           A.ConP cpi ambC ps -> do             (c',_) <- disambiguateConstructor ambC d pars @@ -257,7 +268,7 @@              -- In fs omitted explicit fields are replaced by underscores,             -- and the fields are put in the correct order.-            ps <- insertMissingFields d (const $ A.WildP patNoRange) fs cxs+            ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs cxs              -- We also need to insert missing implicit or instance fields.             ps <- insertImplicitPatterns ExpandLast ps ctel@@ -267,7 +278,7 @@            _ -> return [eq] -      Lit l | A.LitP l' <- p , l == l' -> return []+      Lit l | A.LitP _ l' <- p , l == l' -> return []        _ | A.EqualP{} <- p -> do         itisone <- liftTCM primItIsOne@@ -292,7 +303,7 @@ --   (Includes the 'problemRest'). problemAllVariables :: Problem a -> Bool problemAllVariables problem =-    all (isSolved . snd . asView) $+    all isSolved $       map namedArg (problem ^. problemRestPats) ++ problemInPats problem   where     -- need further splitting:@@ -304,10 +315,12 @@     isSolved A.WildP{}       = True     isSolved A.DotP{}        = True     isSolved A.AbsurdP{}     = True+    -- recursive cases+    isSolved (A.AsP _ _ p)   = isSolved p+    isSolved (A.AnnP _ _ p)  = isSolved p     -- impossible:     isSolved A.ProjP{}       = __IMPOSSIBLE__     isSolved A.DefP{}        = __IMPOSSIBLE__-    isSolved A.AsP{}         = __IMPOSSIBLE__  -- removed by asView     isSolved A.PatternSynP{} = __IMPOSSIBLE__  -- expanded before     isSolved A.EqualP{}      = False -- __IMPOSSIBLE__     isSolved A.WithP{}       = __IMPOSSIBLE__@@ -320,17 +333,18 @@ -- Precondition: The problem has to be solved.  noShadowingOfConstructors :: ProblemEq -> TCM ()-noShadowingOfConstructors (ProblemEq p _ (Dom{domInfo = info, unDom = El _ a})) =-  case snd $ asView p of+noShadowingOfConstructors problem@(ProblemEq p _ (Dom{domInfo = info, unDom = El _ a})) =+  case p of    A.WildP       {} -> return ()    A.AbsurdP     {} -> return ()    A.DotP        {} -> return ()    A.EqualP      {} -> return ()+   A.AsP _ _ p      -> noShadowingOfConstructors $ problem { problemInPat = p }+   A.AnnP _ _ p     -> noShadowingOfConstructors $ problem { problemInPat = p }    A.ConP        {} -> __IMPOSSIBLE__    A.RecP        {} -> __IMPOSSIBLE__    A.ProjP       {} -> __IMPOSSIBLE__    A.DefP        {} -> __IMPOSSIBLE__-   A.AsP         {} -> __IMPOSSIBLE__ -- removed by asView    A.LitP        {} -> __IMPOSSIBLE__    A.PatternSynP {} -> __IMPOSSIBLE__    A.WithP       {} -> __IMPOSSIBLE__@@ -369,6 +383,7 @@           GeneralizableVar{} -> __IMPOSSIBLE__           -- TODO: in the future some stuck primitives might allow constructors           Primitive   {} -> return ()+          PrimitiveSort{} -> return ()       Var   {} -> return ()       Pi    {} -> return ()       Sort  {} -> return ()@@ -408,6 +423,16 @@ checkAbsurdPattern :: AbsurdPattern -> TCM () checkAbsurdPattern (Absurd r a) = ensureEmptyType r a +checkAnnotationPattern :: AnnotationPattern -> TCM ()+checkAnnotationPattern (Ann t a) = do+  reportSDoc "tc.lhs.ann" 15 $+    sep [ "checking type annotation in pattern"+        , nest 2 $ prettyA t+        , nest 2 $ "=" <+> prettyTCM a+        ]+  b <- isType_ t+  equalType a b+ -- | After splitting is complete, we transfer the origins --   We also transfer the locations of absurd patterns, since these haven't --   been introduced yet in the internal pattern.@@ -443,26 +468,26 @@     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+      ((asB , anns , A.ConP pi _ ps) , ConP c (ConPatternInfo i r ft mb l) qs) -> do         let cpi = ConPatternInfo (PatternInfo PatOCon asB) r ft mb l         ConP c cpi <$> transfers ps qs -      ((asB , A.RecP pi fs) , ConP c (ConPatternInfo i r ft mb l) qs) -> do+      ((asB , anns , A.RecP pi fs) , ConP c (ConPatternInfo i r ft mb l) 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-        ps <- insertMissingFields d (const $ A.WildP patNoRange) fs axs+        ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs axs         ConP c cpi <$> transfers ps qs -      ((asB , p) , ConP c (ConPatternInfo i r ft mb l) qs) -> do+      ((asB , anns , p) , ConP c (ConPatternInfo i r ft mb l) qs) -> do         let cpi = ConPatternInfo (PatternInfo (patOrig p) asB) r ft mb l         return $ ConP c cpi qs -      ((asB , p) , VarP _ x) -> return $ VarP (PatternInfo (patOrig p) asB) x+      ((asB , anns , p) , VarP _ x) -> return $ VarP (PatternInfo (patOrig p) asB) x -      ((asB , p) , DotP _ u) -> return $ DotP (PatternInfo (patOrig p) asB) u+      ((asB , anns , p) , DotP _ u) -> return $ DotP (PatternInfo (patOrig p) asB) u -      ((asB , p) , LitP _ l) -> return $ LitP (PatternInfo (patOrig p) asB) l+      ((asB , anns , p) , LitP _ l) -> return $ LitP (PatternInfo (patOrig p) asB) l        _ -> return q @@ -480,6 +505,7 @@     patOrig A.DefP{}        = __IMPOSSIBLE__     patOrig A.PatternSynP{} = __IMPOSSIBLE__     patOrig A.WithP{}       = __IMPOSSIBLE__+    patOrig A.AnnP{}        = __IMPOSSIBLE__      matchingArgs :: NamedArg A.Pattern -> NamedArg DeBruijnPattern -> Bool     matchingArgs p q@@ -504,7 +530,7 @@   reportSDoc "tc.lhs.linear" 30 $ "Checking linearity of pattern variables"   check Map.empty eqs   where-    check :: Map A.BindName Term -> [ProblemEq] -> TCM [ProblemEq]+    check :: Map A.BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]     check _ [] = return []     check vars (eq@(ProblemEq p u a) : eqs) = do       reportSDoc "tc.lhs.linear" 40 $ sep@@ -512,20 +538,28 @@         , prettyA p         , " equal to term "         , prettyTCM u+        , " of type "+        , prettyTCM a         ]       case p of         A.VarP x -> do+          let y = A.unBind x           reportSLn "tc.lhs.linear" 60 $-            let y = A.unBind x-            in "pattern variable " ++ show (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 -> do-              noConstraints $ equalTerm (unDom a) u v+            Just (v , b) -> do+              traceCall (CheckPatternLinearityType $ A.nameConcrete y) $+                noConstraints $ equalType (unDom a) b+              traceCall (CheckPatternLinearityValue $ A.nameConcrete y) $+                noConstraints $ equalTerm (unDom a) u v               check vars eqs             Nothing -> (eq:) <$> do-              check (Map.insert x u vars) eqs+              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+        A.AnnP _ _ A.WildP{} -> continue+        A.AnnP r t p -> (ProblemEq (A.AnnP r t (A.WildP patNoRange)) u a:) <$>+          check vars (ProblemEq p u a : eqs)         A.WildP{}       -> continue         A.DotP{}        -> continue         A.AbsurdP{}     -> continue@@ -563,12 +597,12 @@ -- | Bind as patterns bindAsPatterns :: [AsBinding] -> TCM a -> TCM a bindAsPatterns []                ret = ret-bindAsPatterns (AsB x v a : asb) ret = do+bindAsPatterns (AsB x v a m : asb) ret = do   reportSDoc "tc.lhs.as" 10 $ "as pattern" <+> prettyTCM x <+>     sep [ ":" <+> prettyTCM a         , "=" <+> prettyTCM v         ]-  addLetBinding defaultArgInfo x v a $ bindAsPatterns asb ret+  addLetBinding (setModality m defaultArgInfo) 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.@@ -666,8 +700,8 @@          addContext delta $ do           mapM_ noShadowingOfConstructors eqs-          noPatternMatchingOnCodata qs0 +        arity_a <- arityPiPath a         -- Compute substitution from the out patterns @qs0@         let notProj ProjP{} = False             notProj _       = True@@ -706,15 +740,15 @@             --    type is fully reduced.              weakSub :: Substitution-            weakSub | isJust withSub' = wkS (max 0 $ numPats - arity a) idS -- if numPats < arity, Θ is empty+            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__)+            patSub   = map (patternToTerm . namedArg) (reverse $ take numPats qs0) ++# EmptyS impossible             paramSub = patSub `composeS` weakSub `composeS` withSub          eqs <- addContext delta $ checkPatternLinearity eqs -        leftovers@(LeftoverPatterns patVars asb0 dots absurds otherPats)+        leftovers@(LeftoverPatterns patVars asb0 dots absurds annps otherPats)           <- addContext delta $ getLeftoverPatterns eqs          reportSDoc "tc.lhs.leftover" 30 $ vcat@@ -749,7 +783,7 @@                ]         reportSDoc "tc.lhs.top" 30 $           nest 2 $ vcat-                 [ "vars   = " <+> text (show vars)+                 [ "vars   = " <+> pretty vars                  ]         reportSDoc "tc.lhs.top" 20 $ nest 2 $ "withSub  = " <+> pretty withSub         reportSDoc "tc.lhs.top" 20 $ nest 2 $ "weakSub  = " <+> pretty weakSub@@ -770,6 +804,7 @@             -- Check dot patterns             mapM_ checkDotPattern dots             mapM_ checkAbsurdPattern absurds+            mapM_ checkAnnotationPattern annps            -- Issue2303: don't bind asb' for the continuation (return in lhsResult instead)           ret lhsResult@@ -795,7 +830,7 @@ splitStrategy = filter shouldSplit   where     shouldSplit :: ProblemEq -> Bool-    shouldSplit (ProblemEq p v a) = case snd $ asView p of+    shouldSplit problem@(ProblemEq p v a) = case p of       A.LitP{}    -> True       A.RecP{}    -> True       A.ConP{}    -> True@@ -806,16 +841,18 @@       A.DotP{}    -> False       A.AbsurdP{} -> False +      A.AsP _ _ p  -> shouldSplit $ problem { problemInPat = p }+      A.AnnP _ _ p -> shouldSplit $ problem { problemInPat = p }+       A.ProjP{}       -> __IMPOSSIBLE__       A.DefP{}        -> __IMPOSSIBLE__-      A.AsP{}         -> __IMPOSSIBLE__       A.PatternSynP{} -> __IMPOSSIBLE__       A.WithP{}       -> __IMPOSSIBLE__   -- | The loop (tail-recursive): split at a variable in the problem until problem is solved checkLHS-  :: forall tcm a. (MonadTCM tcm, MonadReduce tcm, MonadAddContext tcm, MonadWriter Blocked_ tcm, HasConstInfo tcm, MonadError TCErr tcm, MonadDebug tcm, MonadReader Nat tcm)+  :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader Nat tcm)   => Maybe QName      -- ^ The name of the definition we are checking.   -> LHSState a       -- ^ The current state.   -> tcm a@@ -825,12 +862,14 @@  updateModality cont st@(LHSState tel ip problem target psplit) = do       let m = getModality target       applyModalityToContext m $ do-        cont $ over (lhsTel . listTel) (map $ inverseApplyModality m) st+        cont $ over (lhsTel . listTel)+                 (map $ inverseApplyModalityButNotQuantity m) st         -- Andreas, 2018-10-23, issue #3309         -- the modalities in the clause telescope also need updating.   checkLHS_ st@(LHSState tel ip problem target psplit) = do-+  reportSDoc "lhs" 10 $ "tel is" <+> prettyTCM tel+  reportSDoc "lhs" 10 $ "ip is" <+> pretty ip   if isSolvedProblem problem then     liftTCM $ (problem ^. problemCont) st   else do@@ -881,24 +920,26 @@              softTypeError $ SplitOnNonVariable v a        let pos = size tel - (i+1)-          (delta1, tel'@(ExtendTel dom adelta2)) = splitTelescopeAt pos tel+          (delta1, tel'@(ExtendTel dom adelta2)) = splitTelescopeAt pos tel -- TODO:: tel' defined but not used        p <- liftTCM $ expandLitPattern p-      case snd $ asView p of-        (A.LitP l)        -> 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+      let splitOnPat = \case+            (A.LitP _ l)      -> 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+            A.AsP _ _ p       -> splitOnPat p+            A.AnnP _ _ p      -> splitOnPat p -        A.VarP{}        -> __IMPOSSIBLE__-        A.WildP{}       -> __IMPOSSIBLE__-        A.DotP{}        -> __IMPOSSIBLE__-        A.AbsurdP{}     -> __IMPOSSIBLE__-        A.ProjP{}       -> __IMPOSSIBLE__-        A.DefP{}        -> __IMPOSSIBLE__-        A.AsP{}         -> __IMPOSSIBLE__-        A.PatternSynP{} -> __IMPOSSIBLE__-        A.WithP{}       -> __IMPOSSIBLE__+            A.VarP{}        -> __IMPOSSIBLE__+            A.WildP{}       -> __IMPOSSIBLE__+            A.DotP{}        -> __IMPOSSIBLE__+            A.AbsurdP{}     -> __IMPOSSIBLE__+            A.ProjP{}       -> __IMPOSSIBLE__+            A.DefP{}        -> __IMPOSSIBLE__+            A.PatternSynP{} -> __IMPOSSIBLE__+            A.WithP{}       -> __IMPOSSIBLE__+      splitOnPat p       splitRest :: NamedArg A.Pattern -> ExceptT TCErr tcm (LHSState a)@@ -913,15 +954,20 @@         ]        -- @p@ should be a projection pattern projection from @target@-      (orig, ambProjName) <- ifJust (A.isProjP p) return $-        addContext tel $ softTypeError $ CannotEliminateWithPattern p (unArg target)+      (orig, ambProjName) <- ifJust (A.isProjP p) return $ addContext tel $ do+        block <- isBlocked target+        softTypeError $ CannotEliminateWithPattern block p (unArg target) -      (projName, projType) <- suspendErrors $ do+      (projName, comatchingAllowed, recName, projType, ai) <- suspendErrors $ do         -- Andreas, 2018-10-18, issue #3289: postfix projections do not have hiding         -- information for their principal argument; we do not parse @{r}.p@ and the like.         let h = if orig == ProjPostfix then Nothing else Just $ getHiding p         addContext tel $ disambiguateProjection h ambProjName target +      unless comatchingAllowed $ do+        hardTypeError . GenericDocError =<< do+          liftTCM $ "Copattern matching is disabled for record" <+> prettyTCM recName+       -- Compute the new rest type by applying the projection type to 'self'.       -- Note: we cannot be in a let binding.       f <- ifJust mf return $ hardTypeError $@@ -931,14 +977,14 @@        -- Compute the new state       let projP    = applyWhen (orig == ProjPostfix) (setHiding NotHidden) $-                       target' $> Named Nothing (ProjP orig projName)+                       Arg ai $ Named Nothing (ProjP orig projName)           ip'      = ip ++ [projP]           -- drop the projection pattern (already splitted)           problem' = over problemRestPats tail problem       liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit)  -    -- | Split a Partial.+    -- Split a Partial.     --     -- Example for splitPartial:     -- @@@ -988,17 +1034,18 @@     --   sigma = fails because several substitutions [[1/i],[1/j]] correspond to phi     -- @ -    splitPartial :: Telescope     -- ^ The types of arguments before the one we split on-                 -> Dom Type      -- ^ The type of the argument we split on-                 -> Abs Telescope -- ^ The types of arguments after the one we split on-                 -> [(A.Expr, A.Expr)] -- ^ [(φ₁ = b1),..,(φn = bn)]+    splitPartial :: Telescope     -- The types of arguments before the one we split on+                 -> Dom Type      -- The type of the argument we split on+                 -> Abs Telescope -- The types of arguments after the one we split on+                 -> [(A.Expr, A.Expr)] -- [(φ₁ = b1),..,(φn = bn)]                  -> ExceptT TCErr tcm (LHSState a)     splitPartial delta1 dom adelta2 ts = do -      unless (domFinite dom) $ liftTCM $ softTypeError . GenericDocError =<<+      unless (domFinite dom) $ liftTCM $ addContext delta1 $+        softTypeError . GenericDocError =<<         hsep [ "Not a finite domain:" , prettyTCM $ unDom dom ] -      tInterval <- liftTCM $ elInf primInterval+      tInterval <- liftTCM $ primIntervalType        names <- liftTCM $ addContext tel $ do         LeftoverPatterns{patternVariables = vars} <- getLeftoverPatterns $ problem ^. problemEqs@@ -1071,9 +1118,9 @@        let oix = size adelta2 -- de brujin index of IsOne           o_n = fromMaybe __IMPOSSIBLE__ $-            flip findIndex ip (\ x -> case namedThing (unArg x) of-                                           VarP _ x -> dbPatVarIndex x == oix-                                           _        -> False)+            findIndex (\ x -> case namedThing (unArg x) of+                                   VarP _ x -> dbPatVarIndex x == oix+                                   _        -> False) ip           delta2' = absApp adelta2 itisone           delta2 = applySubst sigma delta2'           mkConP (Con c _ [])@@ -1097,10 +1144,10 @@       liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n]))  -    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+    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       let delta2 = absApp adelta2 (Lit lit)@@ -1136,12 +1183,12 @@       liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit)  -    splitCon :: Telescope     -- ^ The types of arguments before the one we split on-             -> Dom Type      -- ^ The type of the constructor we split on-             -> Abs Telescope -- ^ The types of arguments after the one we split on-             -> A.Pattern     -- ^ The pattern written by the user-             -> Maybe AmbiguousQName  -- ^ @Just c@ for a (possibly ambiguous) constructor @c@, or-                                      --   @Nothing@ for a record pattern+    splitCon :: Telescope      -- The types of arguments before the one we split on+             -> Dom Type       -- The type of the constructor we split on+             -> Abs Telescope  -- The types of arguments after the one we split on+             -> 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       let delta2 = absBody adelta2@@ -1149,8 +1196,8 @@       reportSDoc "tc.lhs.split" 10 $ vcat         [ "checking lhs"         , nest 2 $ "tel =" <+> prettyTCM tel-        , nest 2 $ "rel =" <+> (text $ show $ getRelevance info)-        , nest 2 $ "mod =" <+> (text $ show $ getModality  info)+        , nest 2 $ "rel =" <+> text (show $ getRelevance info)+        , nest 2 $ "mod =" <+> text (show $ getModality  info)         ]        reportSDoc "tc.lhs.split" 15 $ vcat@@ -1178,11 +1225,21 @@        -- We should be at a data/record type       (dr, d, pars, ixs) <- addContext delta1 $ isDataOrRecordType a+      let isRec = case dr of+            IsData{}   -> False+            IsRecord{} -> True -      checkSortOfSplitVar dr a (Just target)+      checkMatchingAllowed d dr  -- No splitting on coinductive constructors.+      addContext delta1 $ checkSortOfSplitVar dr a delta2 (Just target) +      -- Jesper, 2019-09-13: if the data type we split on is a strict+      -- set, we locally enable --with-K during unification.+      withKIfStrict <- reduce (getSort a) >>= \case+        SSet{} -> return $ locallyTC eSplitOnStrict $ const True+        _      -> return id+       -- The constructor should construct an element of this datatype-      (c, b) <- liftTCM $ addContext delta1 $ case ambC of+      (c :: ConHead, b :: Type) <- liftTCM $ addContext delta1 $ case ambC of         Just ambC -> disambiguateConstructor ambC d pars         Nothing   -> getRecordConstructor d pars a @@ -1209,7 +1266,7 @@           return $ useNamesFromPattern ps gamma         A.RecP _ fs -> do           axs <- map argFromDom . recordFieldNames . theDef <$> getConstInfo d-          ps <- insertMissingFields d (const $ A.WildP patNoRange) fs axs+          ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs axs           ps <- insertImplicitPatterns ExpandLast ps gamma           return $ useNamesFromPattern ps gamma         _ -> __IMPOSSIBLE__@@ -1228,6 +1285,7 @@             , nest 2 $ vcat               [ "c      =" <+> prettyTCM c <+> ":" <+> prettyTCM b               , "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)@@ -1282,14 +1340,18 @@              TelV tel dt <- telView da'              return $ abstract (mapCohesion updCoh <$> tel) a -      liftTCM (unifyIndices delta1Gamma flex da' cixs ixs') >>= \case+      let stuck b errs = softTypeError $ SplitError $+            UnificationStuck b (conName c) (delta1 `abstract` gamma) cixs ixs' errs +      liftTCM (withKIfStrict $ unifyIndices delta1Gamma flex da' cixs ixs') >>= \case+         -- Mismatch.  Report and abort.         NoUnify neg -> hardTypeError $ ImpossibleConstructor (conName c) neg +        UnifyBlocked block -> stuck (Just block) []+         -- Unclear situation.  Try next split.-        DontKnow errs -> softTypeError $ SplitError $-          UnificationStuck (conName c) (delta1 `abstract` gamma) cixs ixs' errs+        UnifyStuck errs -> stuck Nothing errs          -- Success.         Unifies (delta1',rho0,es) -> do@@ -1312,11 +1374,10 @@           -- Andreas, 2010-09-09, save the type.           -- It is relative to Δ₁, but it should be relative to Δ₁'           let a' = applyPatSubst rho1 a-          -- Also remember if we are a record pattern.-          isRec <- isRecord d +          -- Also remember if we are a record pattern.           let cpi = ConPatternInfo { conPInfo   = PatternInfo PatOCon []-                                   , conPRecord = isJust isRec+                                   , conPRecord = isRec                                    , conPFallThrough = False                                    , conPType   = Just $ Arg info a'                                    , conPLazy   = False } -- Don't mark eta-record matches as lazy (#4254)@@ -1352,44 +1413,53 @@           let eqs' = applyPatSubst rho $ problem ^. problemEqs               problem' = set problemEqs eqs' problem +          -- The result type's quantity is set to 0 for erased+          -- constructors, but not if the match is made in an erased+          -- position.+          cq <- getQuantity <$> getConstInfo (conName c)+          let target'' = mapQuantity updResMod target'+                where+                  erased = case getQuantity info of+                    Quantity0{} -> True+                    Quantity1{} -> __IMPOSSIBLE__+                    Quantityω{} -> False+                  -- either sets to Quantity0 or is the identity.+                  updResMod q =+                    case cq of+                     _ | erased  -> q+                     Quantity0{} -> composeQuantity cq q+                                 -- zero-out, preserves origin+                     Quantity1{} -> __IMPOSSIBLE__+                     Quantityω{} -> q+           -- if rest type reduces,           -- extend the split problem by previously not considered patterns-          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target' psplit+          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit            reportSDoc "tc.lhs.top" 12 $ sep             [ "new problem from rest"             , nest 2 $ vcat               [ "delta'  =" <+> prettyTCM (st' ^. lhsTel)-              , "eqs'    =" <+> addContext (st' ^. lhsTel) (prettyTCM $ st' ^. lhsProblem ^. problemEqs)+              , "eqs'    =" <+> addContext (st' ^. lhsTel) (prettyTCM $ st' ^. (lhsProblem . problemEqs))               , "ip'     =" <+> addContext (st' ^. lhsTel) (pretty $ st' ^. lhsOutPat)               ]             ]           return st'  ----- | Ensures that we are not performing pattern matching on codata.+-- | Ensures that we are not performing pattern matching on coinductive constructors. -noPatternMatchingOnCodata :: [NamedArg DeBruijnPattern] -> TCM ()-noPatternMatchingOnCodata = mapM_ (check . namedArg)-  where-  check (VarP {})   = return ()-  check (DotP {})   = return ()-  check (ProjP{})   = return ()-  check (IApplyP{}) = return ()-  check (LitP {})   = return ()  -- Literals are assumed not to be coinductive.-  check (DefP{})    = return () -- we assume we don't generate this for codata.-  check (ConP con _ ps) = do-    reportSDoc "tc.lhs.top" 40 $-      "checking whether" <+> prettyTCM con <+> "is a coinductive constructor"-    TelV _ t <- telView' . defType <$> do getConstInfo $ conName con-    c <- isCoinductive t-    case c of-      Nothing    -> __IMPOSSIBLE__-      Just False -> mapM_ (check . namedArg) ps-      Just True  -> typeError $+checkMatchingAllowed :: (MonadTCError m)+  => 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+  IsRecord ind eta+    | Just CoInductive <- ind -> typeError $         GenericError "Pattern matching on coinductive types is not allowed"+    | not $ patternMatchingAllowed eta -> typeError $ SplitOnNonEtaRecord d+    | otherwise -> return ()+  IsData -> 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@@ -1401,36 +1471,50 @@  -- | A more direct implementation of the specification --   @softTypeError err == suspendErrors (typeError err)@-softTypeError :: (ReadTCState m, MonadError TCErr m, MonadTCEnv m) => TypeError -> m a-softTypeError err = throwError =<< typeError_ err+softTypeError :: (HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => TypeError -> m a+softTypeError err = withCallerCallStack $ \loc ->+  throwError =<< typeError' loc err  -- | A convenient alias for @liftTCM . typeError@. Throws the error directly --   in the TCM even if there is a surrounding monad also implementing --   @MonadError TCErr@.-hardTypeError :: (MonadTCM m) => TypeError -> m a-hardTypeError = liftTCM . typeError+hardTypeError :: (HasCallStack, MonadTCM m) => TypeError -> m a+hardTypeError = withCallerCallStack $ \loc -> liftTCM . typeError' loc +data DataOrRecord+  = IsData+  | IsRecord+    { recordInduction   :: Maybe Induction+    , recordEtaEquality :: EtaEquality+    }+  deriving (Show)+ -- | Check if the type is a data or record type and return its name, --   definition, parameters, and indices. Fails softly if the type could become --   a data/record type by instantiating a variable/metavariable, or fail hard --   otherwise.-isDataOrRecordType :: (MonadTCM m, MonadDebug m, ReadTCState m)-                   => Type-                   -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)-isDataOrRecordType a = liftTCM (reduceB a) >>= \case-  NotBlocked ReallyNotBlocked a -> case unEl a of+isDataOrRecordType+  :: (MonadTCM m, PureTCM m)+  => Type+  -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)+       -- ^ The 'Args' are parameters and indices. +isDataOrRecordType a0 = ifBlocked a0 blocked $ \case+  ReallyNotBlocked -> \ a -> case unEl a of+     -- Subcase: split type is a Def.-    Def d es -> (liftTCM $ theDef <$> getConstInfo d) >>= \case+    Def d es -> liftTCM (theDef <$> getConstInfo d) >>= \case        Datatype{dataPars = np} -> do +        whenM (isInterval a) $ hardTypeError =<< notData+         let (pars, ixs) = splitAt np $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es         return (IsData, d, pars, ixs) -      Record{} -> do+      Record{ recInduction, recEtaEquality' } -> do         let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-        return (IsRecord, d, pars, [])+        return (IsRecord recInduction recEtaEquality', d, pars, [])        -- Issue #2253: the data type could be abstract.       AbstractDefn{} -> hardTypeError . GenericDocError =<< do@@ -1453,11 +1537,13 @@       -- Not data though, at least currently 11/03/2018.       Primitive{}   -> hardTypeError =<< notData +      PrimitiveSort{} -> hardTypeError =<< notData+       GeneralizableVar{} -> __IMPOSSIBLE__ -    -- variable or metavariable: fail softly+    -- variable: fail softly     Var{}      -> softTypeError =<< notData-    MetaV{}    -> softTypeError =<< notData+    MetaV{}    -> __IMPOSSIBLE__  -- That is handled in @blocked@.      -- pi or sort: fail hard     Pi{}       -> hardTypeError =<< notData@@ -1470,12 +1556,21 @@     DontCare{} -> __IMPOSSIBLE__     Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s -  -- Type is blocked on a meta or something else: fail softly-  _ -> softTypeError =<< notData+  -- neutral type: fail softly+  StuckOn{}     -> \ _a -> softTypeError =<< notData+  AbsurdMatch{} -> \ _a -> softTypeError =<< notData -  where notData = liftTCM $ SplitError . NotADatatype <$> buildClosure a+  -- missing clauses: fail hard+  -- TODO: postpone checking of the whole clause until later?+  MissingClauses{} -> \ _a -> hardTypeError =<< notData +  -- underapplied type: should not happen+  Underapplied{} -> __IMPOSSIBLE__ +  where+  notData      = liftTCM $ SplitError . NotADatatype <$> buildClosure a0+  blocked b _a = softTypeError =<< do liftTCM $ SplitError . BlockedType b <$> buildClosure a0+ -- | Get the constructor of the given record type together with its type. --   Throws an error if the type is not a record type. getRecordConstructor@@ -1499,49 +1594,54 @@                     --   @Nothing@ if 'Postfix' projection.   -> AmbiguousQName -- ^ Name of the projection to be disambiguated.   -> Arg Type       -- ^ Record type we are projecting from.-  -> TCM (QName, Arg Type)+  -> 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   -- 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 $ \(r, vs, def) -> case def of-    Record{ recFields = fs } -> do+    Record{ recFields = fs, recInduction, recEtaEquality' = eta } -> do       reportSDoc "tc.lhs.split" 20 $ sep         [ text $ "we are of record type r  = " ++ prettyShow r         , text   "applied to parameters vs = " <+> prettyTCM vs         , text $ "and have fields       fs = " ++ prettyShow (map argFromDom fs)         ]+      let comatching = recInduction == Just CoInductive+                    || copatternMatchingAllowed eta       -- Try the projection candidates.       -- First, we try to find a disambiguation that doesn't produce       -- any new constraints.-      tryDisambiguate False fs r vs $ \ _ ->+      tryDisambiguate False fs r vs comatching $ \ _ ->           -- If this fails, we try again with constraints, but we require           -- the solution to be unique.-          tryDisambiguate True fs r vs $ \case+          tryDisambiguate True fs r vs comatching $ \case             ([]   , []      ) -> __IMPOSSIBLE__             (err:_, []      ) -> throwError err             (_    , disambs@((d,a):_)) -> typeError . GenericDocError =<< vcat               [ "Ambiguous projection " <> prettyTCM d <> "."               , "It could refer to any of"-              , nest 2 $ vcat $ map (prettyDisamb . fst) disambs+              , nest 2 $ vcat $ map (prettyDisambProj . fst) disambs               ]     _ -> __IMPOSSIBLE__    where-    tryDisambiguate constraintsOk fs r vs failure = do+    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.       disambiguations <- mapM (runExceptT . tryProj constraintsOk fs r vs) ds-      case partitionEithers $ NonEmpty.toList disambiguations of-        (_ , (d,a) : disambs) | constraintsOk <= null disambs -> do+      case List1.partitionEithers disambiguations of+        (_ , (d, (a, ai, mst)) : disambs) | constraintsOk <= null disambs -> do+          mapM_ putTC mst -- Activate state changes           -- From here, we have the correctly disambiguated projection.           -- For highlighting, we remember which name we disambiguated to.           -- This is safe here (fingers crossed) as we won't decide on a           -- different projection even if we backtrack and come here again.-          liftTCM $ storeDisambiguatedName d-          return (d,a)+          liftTCM $ storeDisambiguatedProjection d+          return (d, comatching, r, a, ai)         other -> failure other -    notRecord = wrongProj $ NonEmpty.head ds+    notRecord = wrongProj $ List1.head ds      wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a     wrongProj d = softTypeError =<< do@@ -1561,12 +1661,13 @@         [ "Wrong hiding used for projection " , prettyTCM d ]      tryProj-      :: Bool                 -- ^ Are we allowed to create new constraints?-      -> [Dom QName]          -- ^ Fields of record type under consideration.-      -> QName                -- ^ Name of record type we are eliminating.-      -> Args                 -- ^ Parameters of record type we are eliminating.-      -> QName                -- ^ Candidate projection.-      -> ExceptT TCErr TCM (QName, Arg Type)+      :: Bool                 -- Are we allowed to create new constraints?+      -> [Dom QName]          -- Fields of record type under consideration.+      -> QName                -- Name of record type we are eliminating.+      -> Args                 -- Parameters of record type we are eliminating.+      -> QName                -- Candidate projection.+      -> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))+           -- TCState contains possibly new constraints/meta solutions.     tryProj constraintsOk fs r vs d0 = isProjection d0 >>= \case       -- Not a projection       Nothing -> wrongProj d0@@ -1593,7 +1694,10 @@         -- If this was not an ambiguous projection, that's an error.         argd <- maybe (wrongProj d) return $ List.find ((d ==) . unDom) fs -        let ai = setModality (getModality argd) $ projArgInfo proj+        -- 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+        -- correct hiding for the projection pattern in splitRest above.+        let ai = getArgInfo argd          reportSDoc "tc.lhs.split" 20 $ vcat           [ text $ "original proj relevance  = " ++ show (getRelevance argd)@@ -1602,11 +1706,13 @@         -- Andreas, 2016-12-31, issue #2374:         -- We can also disambiguate by hiding info.         -- Andreas, 2018-10-18, issue #3289: postfix projections have no hiding info.-        unless (caseMaybe h True $ sameHiding ai) $ wrongHiding d+        unless (caseMaybe h True $ sameHiding $ projArgInfo proj) $ wrongHiding d          -- Andreas, 2016-12-31, issue #1976: Check parameters.-        suspendErrors $ applyUnless constraintsOk noConstraints $-          checkParameters qr r vs+        let chk = checkParameters qr r vs+        mst <- suspendErrors $+          if constraintsOk then Just . snd <$> localTCStateSaving chk+          else Nothing <$ nonConstraining chk          -- Get the type of projection d applied to "self"         dType <- liftTCM $ defType <$> getConstInfo d  -- full type!@@ -1614,7 +1720,7 @@           [ "we are being projected by dType = " <+> prettyTCM dType           ]         projType <- liftTCM $ dType `piApplyM` vs-        return (d0 , Arg ai projType)+        return (d0, (Arg ai projType, projArgInfo proj, mst))  -- | Disambiguate a constructor based on the data type it is supposed to be --   constructing. Returns the unambiguous constructor name and its type.@@ -1631,55 +1737,76 @@     def@Record{}   -> return $ [conName $ recConHead def]     _              -> __IMPOSSIBLE__ -  -- First, try do disambiguate with noConstraints,-  -- if that fails, try again allowing constraint generation.-  tryDisambiguate False cons d $ \ _ ->-    tryDisambiguate True cons d $ \case-        ([]   , []        ) -> __IMPOSSIBLE__-        (err:_, []        ) -> throwError err-        (_    , disambs@((_c0,c,_a):_)) -> typeError . GenericDocError =<< vcat-          [ "Ambiguous constructor " <> prettyTCM (qnameName $ conName c) <> "."+  -- First, try do disambiguate with nonConstraining,+  -- if that fails, try again allowing constraint/solution generation.+  tryDisambiguate False d cons $ \ _ ->+    tryDisambiguate True d cons $ \case+        ([]   , [] ) -> __IMPOSSIBLE__+        (err:_, [] ) -> throwError err+        -- If all disambiguations point to the same original constructor+        -- meaning that only the parameters may differ,+        -- then throw more specific error.+        (_    , [_]) -> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d cs+        (_    , disambs@(((c,_,_):|_):_)) -> typeError . GenericDocError =<< vcat+          [ "Ambiguous constructor " <> pretty (qnameName c) <> "."           , "It could refer to any of"-          , nest 2 $ vcat $ map (prettyDisamb . fst3) disambs+          , nest 2 $ vcat $ map (prettyDisambCons . conName . snd3) $ List1.concat disambs           ]    where-    tryDisambiguate constraintsOk cons d failure = do+    tryDisambiguate+      :: Bool     -- May we constrain/solve metas to arrive at unique disambiguation?+      -> QName    -- Data/record type.+      -> [QName]  -- Its constructor(s).+      -> ( ( [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+      reportSDoc "tc.lhs.disamb" 30 $ sep $ List.concat $+        [ [ "tryDisambiguate" ]+        , if constraintsOk then [ "(allowing new constraints)" ] else empty+        , map (nest 2 . pretty) $ List1.toList cs+        , [ "against" ]+        , map (nest 2 . pretty) cons+        ]       disambiguations <- mapM (runExceptT . tryCon constraintsOk cons d pars) cs-        -- TODO: can we be more lazy, like using the ListT monad?-      case partitionEithers $ NonEmpty.toList disambiguations of-        -- Andreas, 2019-10-14: The code from which I factored out 'tryDisambiguate'-        -- did allow several disambiguations in case @constraintsOk == False@.-        -- There was no comment explaining why, but "fixing" it and insisting on a-        -- single disambiguation triggers this error in the std-lib-        -- (version 4fca6541edbf5951cff5048b61235fe87d376d84):-        ---        --   Data/List/Relation/Unary/All/Properties.agda:462,15-17-        --   Ambiguous constructor []₁.-        --   It could refer to any of-        --     _._.Pointwise.[] (introduced at Data/List/Relation/Binary/Pointwise.agda:40,6-15)-        --     [] (introduced at Data/List/Relation/Binary/Pointwise.agda:40,6-15)-        --   when checking that the pattern [] has type x ≋ y-        ---        -- There are problems with this error message (reported as issue #4130):-        ---        --   * the constructor [] is printed as []₁-        --   * the two (identical) locations point to the definition of data type Pointwise-        --     - not to the constructor []-        --     - not offering a clue which imports generated the ambiguity-        ---        -- (These should be fixed at some point.)-        -- It is not entirely clear to me that the ambiguity is safe to ignore,-        -- but let's go with it for the sake of preserving the current behavior of Agda.-        -- Thus, only when 'constraintsOk' we require 'null disambs':-        -- (Note that in Haskell, boolean implication is '<=' rather than '=>'.)-        (_, (c0,c,a) : disambs) | constraintsOk <= null disambs -> do-          -- If constructor pattern was ambiguous,-          -- remember our choice for highlighting info.-          when (isAmbiguous ambC) $ liftTCM $ storeDisambiguatedName c0+      -- 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,+      -- report all alternatives in the error message.+      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+      dedupCons fits0 >>= \case++        -- Single candidate remains.+        [ (c0,c,(a,mst)) :| [] ] -> do+          reportSDoc "tc.lhs.disamb" 30 $ sep $+            [ "tryDisambiguate suceeds with"+            , pretty c0+            , ":"+            , prettyTCM a+            ]+          -- Andreas, 2020-06-16, issue #4135+          -- If disambiguation succeeded with new constraints/solutions,+          -- put them into action.+          whenJust mst putTC+          -- If there are multiple candidates for the constructor pattern, exactly one of+          -- which type checks, remember our choice for highlighting info.+          when (isAmbiguous ambC) $ liftTCM $+            storeDisambiguatedConstructor (conInductive c) c0           return (c,a)-        other -> failure other +        -- Either no candidate constructor in 'cs' type checks, or multiple candidates+        -- type check.+        groups -> failure (errs, groups)+     abstractConstructor c = softTypeError $       AbstractConstructorNotInScope c @@ -1687,12 +1814,15 @@       ConstructorPatternInWrongDatatype c d      tryCon-      :: Bool        -- ^ Are we allowed to create new constraints?-      -> [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)+      :: 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__       Left SigAbstract -> abstractConstructor c@@ -1712,20 +1842,68 @@         -- but the extra check here is non-invasive to the existing code.         -- Andreas, 2016-12-31 fixing issue #1975         -- Do this also for constructors which were originally ambiguous.-        suspendErrors $ applyUnless constraintsOk noConstraints $-          checkConstructorParameters c d pars+        let chk = checkConstructorParameters c d pars+        mst <- suspendErrors $+          if constraintsOk then Just . snd <$> localTCStateSaving chk+          else Nothing <$ nonConstraining chk -        -- Get the type from the original constructor+        -- Get the type from the original constructor.+        -- Andreas, 2020-06-17 TODO:+        -- Couldn't we return this type from checkConstructorParameters?         cType <- (`piApply` pars) . defType <$> getConInfo con -        return (c, con, cType)+        return (c, con, (cType, mst)) -prettyDisamb :: QName -> TCM Doc-prettyDisamb x = do+    -- This deduplication identifies different names of the same+    -- constructor, ensuring that the "ambiguous constructor" error+    -- does not fire for the case described in #4130.+    --+    -- Andreas, 2020-06-17, issue #4135:+    -- However, we need to distinguish different occurrences+    -- of the same original constructor if it is used+    -- with different data parameters, as recorded in the @Type@.+    dedupCons ::+      forall a.       [ (a, ConHead, (Type, Maybe TCState)) ]+         -> TCM [ List1 (a, ConHead, (Type, Maybe TCState)) ]+    dedupCons cands = do+      -- Group candidates by original constructor name.+      let groups = List1.groupWith (conName . snd3) cands+      -- Eliminate duplicates (same type) from groups.+      mapM (List1.nubM (cmpM `on` thd3)) groups+      where+      -- The types come possibly with their own state.+      cmpM (a1, mst1) (a2, mst2) = do+        let cmpTypes = tryConversion $ equalType a1 a2+        case (mst1, mst2) of+          (Nothing, Nothing) -> cmpTypes+          (Just st, Nothing) -> inState st cmpTypes+          (Nothing, Just st) -> inState st cmpTypes+          -- Andreas, 2020-06-17, issue #4135.+          -- If the state has diverged into two states we give up.+          -- For instance, one state may say `?0 := true`+          -- and the other `?0 := false`.+          -- The types may be both `D ?0`, which is the same+          -- but diverges in the different states.+          -- We do not check states for equality.+          --+          -- Of course, this is conservative and not maximally extensional.+          -- We might throw an ambiguity error too eagerly,+          -- but this can always be worked around.+          (Just{},  Just{})  -> return False+      inState st m = localTCState $ do putTC st; m+++prettyDisamb :: (QName -> Maybe (Range' SrcFile)) -> QName -> TCM Doc+prettyDisamb f x = do   let d  = pretty =<< dropTopLevelModule x-  let mr = lastMaybe $ filter (noRange /=) $ map nameBindingSite $ mnameToList $ qnameModule x-  caseMaybe mr d $ \ r -> d <+> ("(introduced at " <> prettyTCM r <> ")")+  caseMaybe (f x) d $ \ r -> d <+> ("(introduced at " <> prettyTCM r <> ")") +-- | For Ambiguous Projection errors, print the last range in 'qnameModule'.+--   For Ambiguous Constructor errors, print the range in 'qnameName'. This fixes the bad+--   error message in #4130.+prettyDisambProj, prettyDisambCons :: QName -> TCM Doc+prettyDisambProj = prettyDisamb $ lastMaybe . filter (noRange /=) . map nameBindingSite . mnameToList . qnameModule+prettyDisambCons = prettyDisamb $ Just . nameBindingSite . qnameName  -- | @checkConstructorParameters c d pars@ checks that the data/record type --   behind @c@ is has initial parameters (coming e.g. from a module instantiation)@@ -1748,33 +1926,84 @@   case a of     Def d0 es -> do -- compare parameters       let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      reportSDoc "tc.lhs.split" 40 $-        vcat [ 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-             ]+      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__ -checkSortOfSplitVar :: (MonadTCM m, MonadReduce m, MonadError TCErr m, ReadTCState m, MonadDebug m,+checkSortOfSplitVar :: (MonadTCM m, PureTCM m, MonadError TCErr m,                         LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)-                    => DataOrRecord -> a -> Maybe ty -> m ()-checkSortOfSplitVar dr a mtarget = do-  infOk <- optOmegaInOmega <$> pragmaOptions+                    => DataOrRecord -> a -> Telescope -> Maybe ty -> m ()+checkSortOfSplitVar dr a tel mtarget = do   liftTCM (reduce $ getSort a) >>= \case-    Type{} -> return ()-    Prop{}-      | IsRecord <- dr         -> return ()-      | Just target <- mtarget -> unlessM (isPropM target) splitOnPropError-      | otherwise              -> splitOnPropError-    Inf{} | infOk -> return ()-    _      -> softTypeError =<< do-      liftTCM $ GenericDocError <$> sep+    sa@Type{} -> whenM isTwoLevelEnabled checkFibrantSplit+    Prop{} -> checkPropSplit+    Inf IsFibrant _ -> whenM isTwoLevelEnabled checkFibrantSplit+    Inf IsStrict _ -> return ()+    SSet{} -> return ()+    sa      -> softTypeError =<< do+      liftTCM $ SortOfSplitVarError <$> isBlocked sa <*> sep         [ "Cannot split on datatype in sort" , prettyTCM (getSort a) ]    where+    checkPropSplit+      | IsRecord _ _ <- dr     = return ()+      | Just target <- mtarget = do+        reportSDoc "tc.sort.check" 20 $ "target prop:" <+> prettyTCM target+        checkIsProp target+      | otherwise              = do+          reportSDoc "tc.sort.check" 20 $ "no target prop"+          splitOnPropError++    checkIsProp t = runBlocked (isPropM t) >>= \case+      Left b      -> splitOnPropError -- TODO+      Right False -> splitOnPropError+      Right True  -> return ()++    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+      | otherwise              = do+          reportSDoc "tc.sort.check" 20 $ "no target"+          splitOnFibrantError Nothing++    -- Cofibrant types are those that could be the domain of a fibrant+    -- pi type. (Notion by C. Sattler).+    checkIsCoFibrant t = runBlocked (isCoFibrantSort t) >>= \case+      Left b      -> splitOnFibrantError' t $ Just b+      Right False -> unlessM (isInterval t) $+                       splitOnFibrantError' t $ Nothing+      Right True  -> return ()++    checkIsFibrant t = runBlocked (isFibrant t) >>= \case+      Left b      -> splitOnFibrantError $ Just b+      Right False -> splitOnFibrantError Nothing+      Right True  -> return ()+     splitOnPropError = softTypeError $ GenericError       "Cannot split on datatype in Prop unless target is in Prop"++    splitOnFibrantError' t mb = softTypeError =<< do+      liftTCM $ SortOfSplitVarError mb <$> fsep+        [ "Cannot eliminate fibrant type" , prettyTCM a+        , "unless context type", prettyTCM t, "is also fibrant."+        ]++    splitOnFibrantError mb = softTypeError =<< do+      liftTCM $ SortOfSplitVarError mb <$> fsep+        [ "Cannot eliminate fibrant type" , prettyTCM a+        , "unless target type is also fibrant"+        ]

src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs view

@@ -3,6 +3,9 @@  import Prelude hiding (null) +import Control.Monad.Except+import Control.Monad.IO.Class+ import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Info@@ -28,13 +31,15 @@  -- | Insert implicit patterns in a list of patterns. --   Even if 'DontExpandLast', trailing SIZELT patterns are inserted.-insertImplicitPatterns :: ExpandHidden -> [NamedArg A.Pattern] ->-                          Telescope -> TCM [NamedArg A.Pattern]+insertImplicitPatterns+  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)+  => ExpandHidden -> [NamedArg A.Pattern]+  -> Telescope -> m [NamedArg A.Pattern] insertImplicitPatterns exh ps tel =   insertImplicitPatternsT exh ps (telePi tel __DUMMY_TYPE__)  -- | Insert trailing SizeLt patterns, if any.-insertImplicitSizeLtPatterns :: Type -> TCM [NamedArg A.Pattern]+insertImplicitSizeLtPatterns :: PureTCM m => Type -> m [NamedArg A.Pattern] insertImplicitSizeLtPatterns t = do   -- Testing for SizeLt.  In case of blocked type, we return no.   -- We assume that on the LHS, we know the type.  (TODO: Sufficient?)@@ -52,8 +57,10 @@  -- | Insert implicit patterns in a list of patterns. --   Even if 'DontExpandLast', trailing SIZELT patterns are inserted.-insertImplicitPatternsT :: ExpandHidden -> [NamedArg A.Pattern] -> Type ->-                           TCM [NamedArg A.Pattern]+insertImplicitPatternsT+  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)+  => ExpandHidden -> [NamedArg A.Pattern] -> Type+  -> m [NamedArg A.Pattern] insertImplicitPatternsT DontExpandLast [] a = insertImplicitSizeLtPatterns a insertImplicitPatternsT exh            ps a = do   TelV tel b <- telViewUpTo' (-1) (not . visible) a@@ -72,7 +79,7 @@          ]   case ps of     [] -> insImp dummy tel-    p : _ -> do+    p : _ -> setCurrentRange p $ do       -- Andreas, 2015-05-11.       -- If p is a projection pattern, make it visible for the purpose of       -- calling insImp / insertImplicit, to get correct behavior.

src/full/Agda/TypeChecking/Rules/LHS/Problem.hs view

@@ -4,7 +4,7 @@        , FlexChoice(..) , ChooseFlex(..)        , ProblemEq(..) , Problem(..) , problemEqs        , problemRestPats, problemCont, problemInPats-       , AsBinding(..) , DotPattern(..) , AbsurdPattern(..)+       , AsBinding(..) , DotPattern(..) , AbsurdPattern(..), AnnotationPattern(..)        , LHSState(..) , lhsTel , lhsOutPat , lhsProblem , lhsTarget        , LeftoverPatterns(..), getLeftoverPatterns, getUserVariableNames        ) where@@ -14,13 +14,11 @@ import Control.Arrow ( (***) ) import Control.Monad.Writer hiding ((<>)) -import Data.Foldable ( Foldable )+import Data.Functor (($>)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List ( partition )-import Data.Monoid ( Monoid, mempty, mappend, mconcat ) import Data.Semigroup ( Semigroup, (<>) )-import Data.Set (Set) import qualified Data.Set as Set  import Agda.Syntax.Common@@ -29,13 +27,11 @@ import Agda.Syntax.Abstract (ProblemEq(..)) import qualified Agda.Syntax.Abstract as A -import Agda.TypeChecking.Monad (TCM, IsForced(..), addContext, lookupSection, currentModule)-import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce-import qualified Agda.TypeChecking.Pretty as P import Agda.TypeChecking.Pretty  import Agda.Utils.Lens@@ -216,9 +212,10 @@ problemInPats :: Problem a -> [A.Pattern] problemInPats = map problemInPat . (^. problemEqs) -data AsBinding = AsB Name Term Type+data AsBinding = AsB Name Term Type Modality data DotPattern = Dot A.Expr Term (Dom Type) data AbsurdPattern = Absurd Range Type+data AnnotationPattern = Ann A.Expr Type  -- | State worked on during the main loop of checking a lhs. --   [Ulf Norell's PhD, page. 35]@@ -264,6 +261,7 @@   , asPatterns       :: [AsBinding]   , dotPatterns      :: [DotPattern]   , absurdPatterns   :: [AbsurdPattern]+  , typeAnnotations  :: [AnnotationPattern]   , otherPatterns    :: [A.Pattern]   } @@ -273,40 +271,53 @@     , asPatterns       = asPatterns x ++ asPatterns y     , dotPatterns      = dotPatterns x ++ dotPatterns y     , absurdPatterns   = absurdPatterns x ++ absurdPatterns y+    , typeAnnotations  = typeAnnotations x ++ typeAnnotations y     , otherPatterns    = otherPatterns x ++ otherPatterns y     } +instance Null LeftoverPatterns where+  empty = LeftoverPatterns empty [] [] [] [] []+  null (LeftoverPatterns as bs cs ds es fs) = null as && null bs && null cs && null ds && null es && null fs++ instance Monoid LeftoverPatterns where-  mempty  = LeftoverPatterns empty [] [] [] []+  mempty  = empty   mappend = (<>) +instance PP.Pretty PatVarPosition where+  pretty = PP.text . show+ instance PrettyTCM LeftoverPatterns where-  prettyTCM (LeftoverPatterns varp asb dotp absurdp otherp) = vcat-    [ "pattern variables: " <+> text (show varp)+  prettyTCM (LeftoverPatterns varp asb dotp absurdp annp otherp) = vcat+    [ "pattern variables: " <+> pretty (IntMap.toList varp)     , "as bindings:       " <+> prettyList_ (map prettyTCM asb)     , "dot patterns:      " <+> prettyList_ (map prettyTCM dotp)     , "absurd patterns:   " <+> prettyList_ (map prettyTCM absurdp)+    , "type annotations:  " <+> prettyList_ (map prettyTCM annp)     , "other patterns:    " <+> prettyList_ (map prettyA otherp)     ]  -- | Classify remaining patterns after splitting is complete into pattern --   variables, as patterns, dot patterns, and absurd patterns. --   Precondition: there are no more constructor patterns.-getLeftoverPatterns :: [ProblemEq] -> TCM LeftoverPatterns+getLeftoverPatterns+  :: forall m. PureTCM m+  => [ProblemEq] -> m LeftoverPatterns getLeftoverPatterns eqs = do   reportSDoc "tc.lhs.top" 30 $ "classifying leftover patterns"   params <- Set.fromList . teleNames <$> (lookupSection =<< currentModule)   let isParamName = (`Set.member` params) . nameToArgName   mconcat <$> mapM (getLeftoverPattern isParamName) eqs   where-    patternVariable x i  = LeftoverPatterns (singleton (i,[(x,PVLocal)])) [] [] [] []-    moduleParameter x i  = LeftoverPatterns (singleton (i,[(x,PVParam)])) [] [] [] []-    asPattern x v a      = LeftoverPatterns empty [AsB x v (unDom a)] [] [] []-    dotPattern e v a     = LeftoverPatterns empty [] [Dot e v a] [] []-    absurdPattern info a = LeftoverPatterns empty [] [] [Absurd info a] []-    otherPattern p       = LeftoverPatterns empty [] [] [] [p]+    patternVariable x i  = empty { patternVariables = singleton (i,[(x,PVLocal)]) }+    moduleParameter x i  = empty { patternVariables = singleton (i,[(x,PVParam)]) }+    asPattern x v a      = empty { asPatterns       = singleton (AsB x v (unDom a) (getModality a)) }+    dotPattern e v a     = empty { dotPatterns      = singleton (Dot e v a) }+    absurdPattern info a = empty { absurdPatterns   = singleton (Absurd info a) }+    annPattern t a       = empty { typeAnnotations  = singleton (Ann t a) }+    otherPattern p       = empty { otherPatterns    = singleton p } -    getLeftoverPattern :: (A.Name -> Bool) -> ProblemEq -> TCM LeftoverPatterns+    getLeftoverPattern :: (A.Name -> Bool) -> ProblemEq -> m LeftoverPatterns     getLeftoverPattern isParamName (ProblemEq p v a) = case p of       (A.VarP A.BindName{unBind = x}) -> isEtaVar v (unDom a) >>= \case         Just i  | isParamName x -> return $ moduleParameter x i@@ -317,6 +328,8 @@         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.AnnP info t p) -> (annPattern t (unDom a) `mappend`) <$> do+        getLeftoverPattern isParamName $ ProblemEq p v a       _                 -> return $ otherPattern p  -- | Build a renaming for the internal patterns using variable names from@@ -335,25 +348,29 @@     makeVar :: Dom Type -> Int -> Writer [AsBinding] (Maybe A.Name)     makeVar a i = case partitionIsParam (IntMap.findWithDefault [] i names) of       ([]     , [])   -> return Nothing-      ((x:xs) , [])   -> tellAsBindings xs *> return (Just x)-      (xs     , y:ys) -> tellAsBindings (xs ++ ys) *> return (Just y)+      ((x:xs) , [])   -> tellAsBindings xs $> (Just x)+      (xs     , y:ys) -> tellAsBindings (xs ++ ys) $> (Just y)       where-        tellAsBindings = tell . map (\y -> AsB y (var i) (unDom a))+        tellAsBindings = tell . map (\y -> AsB y (var i) (unDom a) (getModality a))      partitionIsParam :: [(A.Name,PatVarPosition)] -> ([A.Name],[A.Name])-    partitionIsParam = (map fst *** map fst) . (partition $ (== PVParam) . snd)+    partitionIsParam = (map fst *** map fst) . partition ((== PVParam) . snd)  -instance Subst Term (Problem a) where+instance Subst (Problem a) where+  type SubstArg (Problem a) = Term   applySubst rho (Problem eqs rps cont) = Problem (applySubst rho eqs) rps cont -instance Subst Term AsBinding where-  applySubst rho (AsB x v a) = uncurry (AsB x) $ applySubst rho (v, a)+instance Subst AsBinding where+  type SubstArg AsBinding = Term+  applySubst rho (AsB x v a m) = (\(v,a) -> AsB x v a m) $ applySubst rho (v, a) -instance Subst Term DotPattern where+instance Subst DotPattern where+  type SubstArg DotPattern = Term   applySubst rho (Dot e v a) = uncurry (Dot e) $ applySubst rho (v, a) -instance Subst Term AbsurdPattern where+instance Subst AbsurdPattern where+  type SubstArg AbsurdPattern = Term   applySubst rho (Absurd r a) = Absurd r $ applySubst rho a  instance PrettyTCM ProblemEq where@@ -364,7 +381,7 @@     ]  instance PrettyTCM AsBinding where-  prettyTCM (AsB x v a) =+  prettyTCM (AsB x v a m) =     sep [ prettyTCM x <> "@" <> parens (prettyTCM v)         , nest 2 $ ":" <+> prettyTCM a         ]@@ -379,19 +396,22 @@ instance PrettyTCM AbsurdPattern where   prettyTCM (Absurd r a) = "() :" <+> prettyTCM a +instance PrettyTCM AnnotationPattern where+  prettyTCM (Ann a p) = prettyTCM p <+> ":" <+> prettyA a+ instance PP.Pretty AsBinding where-  pretty (AsB x v a) =+  pretty (AsB x v a m) =     PP.pretty x PP.<+> "=" PP.<+>       PP.hang (PP.pretty v PP.<+> ":") 2 (PP.pretty a)  instance InstantiateFull AsBinding where-  instantiateFull' (AsB x v a) = AsB x <$> instantiateFull' v <*> instantiateFull' a+  instantiateFull' (AsB x v a m) = AsB x <$> instantiateFull' v <*> instantiateFull' a <*> pure m  instance PrettyTCM (LHSState a) where   prettyTCM (LHSState tel outPat (Problem eqs rps _) target _) = vcat     [ "tel             = " <+> prettyTCM tel     , "outPat          = " <+> addContext tel (prettyTCMPatternList outPat)     , "problemEqs      = " <+> addContext tel (prettyList_ $ map prettyTCM eqs)-    , "problemRestPats = " <+> prettyList_ (return $ prettyA rps)+    , "problemRestPats = " <+> prettyList_ (map prettyA rps)     , "target          = " <+> addContext tel (prettyTCM target)     ]

src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs view

@@ -2,6 +2,7 @@ module Agda.TypeChecking.Rules.LHS.ProblemRest where  import Control.Monad+import Control.Monad.Except  import Data.Maybe @@ -41,7 +42,7 @@         -- is significant for implicit insertion.         A.VarP A.BindName{unBind = x}           | not (isNoName x)-          , visible dom || (getOrigin ai == UserWritten && nm == Nothing) ->+          , visible dom || (getOrigin ai == UserWritten && isNothing nm) ->           dom{ unDom = (nameToArgName x, a) }         A.AbsurdP{} | visible dom -> dom{ unDom = (stringToArgName "()", a) }         A.PatternSynP{} -> __IMPOSSIBLE__  -- ensure there are no syns left@@ -49,7 +50,9 @@         _ | visible dom && isNoName y -> dom{ unDom = (stringToArgName "x", a) }           | otherwise                  -> dom -useNamesFromProblemEqs :: [ProblemEq] -> Telescope -> TCM Telescope+useNamesFromProblemEqs+  :: forall m. PureTCM m+  => [ProblemEq] -> Telescope -> m Telescope useNamesFromProblemEqs eqs tel = addContext tel $ do   names <- fst . getUserVariableNames tel . patternVariables <$> getLeftoverPatterns eqs   let argNames = map (fmap nameToArgName) names@@ -100,7 +103,9 @@  -- | 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 :: LHSState a -> TCM (LHSState a)+updateProblemRest+  :: forall m a. (PureTCM m, MonadError TCErr m, MonadTrace m, MonadFresh NameId m)+  => LHSState a -> m (LHSState a) updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit) = do   ps <- addContext tel0 $ insertImplicitPatternsT ExpandLast ps $ unArg a   reportSDoc "tc.lhs.imp" 20 $@@ -109,7 +114,7 @@   let m = length $ takeWhile (isNothing . A.isProjP) ps   (TelV gamma b, boundary) <- telViewUpToPathBoundaryP m $ unArg a   forM_ (zip ps (telToList gamma)) $ \(p, a) ->-    unless (sameHiding p a) $ typeError WrongHidingInLHS+    unless (sameHiding p a) $ setCurrentRange p $ typeError WrongHidingInLHS   let tel1      = useNamesFromPattern ps gamma       n         = size tel1       (ps1,ps2) = splitAt n ps

src/full/Agda/TypeChecking/Rules/LHS/Unify.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE NondecreasingIndentation   #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE NondecreasingIndentation #-}  -- | Unification algorithm for specializing datatype indices, as described in --     \"Unifiers as Equivalences: Proof-Relevant Unification of Dependently@@ -32,7 +31,7 @@ --   - A *negative success* @NoUnify err@ means that a conflicting equation --     was found (e.g an equation between two distinct constructors or a cycle). -----   - A *failure* @DontKnow err@ means that the unifier got stuck.+--   - A *failure* @UnifyStuck err@ means that the unifier got stuck. -- --   The unification algorithm itself consists of two parts: --@@ -125,17 +124,16 @@  import Control.Monad import Control.Monad.State-import Control.Monad.Writer (WriterT(..), MonadWriter(..), Monoid(..))+import Control.Monad.Writer (WriterT(..), MonadWriter(..))+import Control.Monad.Except  import Data.Semigroup hiding (Arg) import qualified Data.List as List import qualified Data.IntSet as IntSet-import Data.IntSet (IntSet) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) -import Data.Foldable (Foldable)-import Data.Traversable (Traversable,traverse)+import qualified Agda.Benchmarking as Bench  import Agda.Interaction.Options (optInjectiveTypeConstructors) @@ -145,8 +143,7 @@  import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Monad.Builtin (constructorForm)-import Agda.TypeChecking.Conversion -- equalTerm+import Agda.TypeChecking.Conversion.Pure import Agda.TypeChecking.Constraints import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Irrelevance@@ -163,6 +160,8 @@  import Agda.TypeChecking.Rules.LHS.Problem +import Agda.Utils.Benchmark+import Agda.Utils.Either import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens@@ -175,6 +174,7 @@ import Agda.Utils.Permutation import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Tuple  import Agda.Utils.Impossible @@ -186,9 +186,10 @@   )  data UnificationResult' a-  = Unifies  a                    -- ^ Unification succeeded.-  | NoUnify  NegativeUnification  -- ^ Terms are not unifiable.-  | DontKnow [UnificationFailure] -- ^ Some other error happened, unification got stuck.+  = Unifies  a                        -- ^ Unification succeeded.+  | NoUnify  NegativeUnification      -- ^ Terms are not unifiable.+  | UnifyBlocked Blocker              -- ^ Unification got blocked on a metavariable+  | UnifyStuck   [UnificationFailure] -- ^ Some other error happened, unification got stuck.   deriving (Show, Functor, Foldable, Traversable)  -- | Unify indices.@@ -203,27 +204,39 @@ -- --   The result is the most general unifier of @us@ and @vs@. unifyIndices-  :: MonadTCM tcm+  :: (PureTCM m, MonadBench m, BenchPhase m ~ Bench.Phase)   => Telescope     -- ^ @gamma@   -> FlexibleVars  -- ^ @flex@   -> Type          -- ^ @a@   -> Args          -- ^ @us@   -> Args          -- ^ @vs@-  -> tcm UnificationResult-unifyIndices tel flex a [] [] = return $ Unifies (tel, idS, [])-unifyIndices tel flex a us vs = liftTCM $ Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $ do+  -> m UnificationResult+unifyIndices tel flex a us vs =+  Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $+    unifyIndices' tel flex a us vs++unifyIndices'+  :: (PureTCM m)+  => Telescope     -- ^ @gamma@+  -> FlexibleVars  -- ^ @flex@+  -> Type          -- ^ @a@+  -> Args          -- ^ @us@+  -> Args          -- ^ @vs@+  -> m UnificationResult+unifyIndices' tel flex a [] [] = return $ Unifies (tel, idS, [])+unifyIndices' tel flex a us vs = do     reportSDoc "tc.lhs.unify" 10 $       sep [ "unifyIndices"-          , nest 2 $ prettyTCM tel-          , nest 2 $ addContext tel $ text $ show $ map flexVar flex-          , nest 2 $ addContext tel $ parens (prettyTCM a)-          , nest 2 $ addContext tel $ prettyList $ map prettyTCM us-          , nest 2 $ addContext tel $ prettyList $ map prettyTCM vs+          , ("tel  =" <+>) $ nest 2 $ prettyTCM tel+          , ("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           ]     initialState    <- initUnifyState tel flex a us vs     reportSDoc "tc.lhs.unify" 20 $ "initial unifyState:" <+> prettyTCM initialState     reportSDoc "tc.lhs.unify" 70 $ "initial unifyState:" <+> text (show initialState)-    (result,output) <- runUnifyM $ unify initialState rightToLeftStrategy+    (result,output) <- runUnifyLogT $ unify initialState rightToLeftStrategy     let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState)     return $ fmap (\s -> (varTel s , unifySubst output , ps)) result @@ -240,10 +253,10 @@ instance Reduce Equality where   reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v -eqConstructorForm :: Equality -> TCM Equality+eqConstructorForm :: HasBuiltins m => Equality -> m Equality eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v -eqUnLevel :: Equality -> TCM Equality+eqUnLevel :: HasBuiltins m => Equality -> m Equality eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v   where     unLevel (Level l) = reallyUnLevelView l@@ -322,7 +335,9 @@       delta = eqTel state       prettyEquality x y = prettyTCM x <+> "=?=" <+> prettyTCM y -initUnifyState :: Telescope -> FlexibleVars -> Type -> Args -> Args -> TCM UnifyState+initUnifyState+  :: PureTCM m+  => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState initUnifyState tel flex a lhs rhs = do   (tel, a, lhs, rhs) <- instantiateFull (tel, a, lhs, rhs)   let n = size lhs@@ -402,7 +417,7 @@     permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars     permuteFlex perm =       mapMaybe $ \(FlexibleVar ai fc k p x) ->-        FlexibleVar ai fc k p <$> List.findIndex (x==) (permPicks perm)+        FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm)  applyUnder :: Int -> Telescope -> Term -> Telescope applyUnder k tel u@@ -588,7 +603,7 @@       , "rhs:        " <+> prettyList_ (map prettyTCM vs)       ]) -type UnifyStrategy = UnifyState -> ListT TCM UnifyStep+type UnifyStrategy = forall m. (PureTCM m, MonadPlus m) => UnifyState -> m UnifyStep  --UNUSED Liang-Ting Chen 2019-07-16 --leftToRightStrategy :: UnifyStrategy@@ -603,39 +618,38 @@  completeStrategyAt :: Int -> UnifyStrategy completeStrategyAt k s = msum $ map (\strat -> strat k s) $-    [ skipIrrelevantStrategy-    , basicUnifyStrategy-    , literalStrategy-    , dataStrategy-    , etaExpandVarStrategy-    , etaExpandEquationStrategy-    , injectiveTypeConStrategy-    , injectivePragmaStrategy-    , simplifySizesStrategy-    , checkEqualityStrategy+-- ASR (2021-02-07). The below eta-expansions are required by GHC >=+-- 9.0.1 (see Issue #4955).+    [ (\n -> skipIrrelevantStrategy n)+    , (\n -> basicUnifyStrategy n)+    , (\n -> literalStrategy n)+    , (\n -> dataStrategy n)+    , (\n -> etaExpandVarStrategy  n)+    , (\n -> etaExpandEquationStrategy n)+    , (\n -> injectiveTypeConStrategy n)+    , (\n -> injectivePragmaStrategy n)+    , (\n -> simplifySizesStrategy n)+    , (\n -> checkEqualityStrategy n)     ]  -- | @isHom n x@ returns x lowered by n if the variables 0..n-1 don't occur in x. -- -- This is naturally sensitive to normalization.-isHom :: (Free a, Subst Term a) => Int -> a -> Maybe a+isHom :: (Free a, Subst a) => Int -> a -> Maybe a isHom n x = do   guard $ getAll $ runFree (All . (>= n)) IgnoreNot x   return $ raise (-n) x  findFlexible :: Int -> FlexibleVars -> Maybe (FlexibleVar Nat)-findFlexible i flex =-  let flex'      = map flexVar flex-      flexible i = i `elem` flex'-  in List.find ((i ==) . flexVar) flex+findFlexible i flex = List.find ((i ==) . flexVar) flex  basicUnifyStrategy :: Int -> UnifyStrategy basicUnifyStrategy k s = do-  Equal dom@Dom{unDom = a} u v <- liftTCM $ eqUnLevel (getEquality k s)+  Equal dom@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) <- liftTCM $ addContext (varTel s) $ (,) <$> isEtaVar u ha <*> isEtaVar v ha-  liftTCM $ reportSDoc "tc.lhs.unify" 30 $ "isEtaVar results: " <+> text (show [mi,mj])+  (mi, mj) <- addContext (varTel s) $ (,) <$> isEtaVar u ha <*> isEtaVar v ha+  reportSDoc "tc.lhs.unify" 30 $ "isEtaVar results: " <+> text (show [mi,mj])   case (mi, mj) of     (Just i, Just j)      | i == j -> mzero -- Taken care of by checkEqualityStrategy@@ -647,9 +661,9 @@                                 , return (Solution k dom{unDom = ha} fj u)]            firstTryRight = msum [ return (Solution k dom{unDom = ha} fj u)                                 , return (Solution k dom{unDom = ha} fi v)]-       liftTCM $ reportSDoc "tc.lhs.unify" 40 $ "fi = " <+> text (show fi)-       liftTCM $ reportSDoc "tc.lhs.unify" 40 $ "fj = " <+> text (show fj)-       liftTCM $ reportSDoc "tc.lhs.unify" 40 $ "chooseFlex: " <+> text (show choice)+       reportSDoc "tc.lhs.unify" 40 $ "fi = " <+> text (show fi)+       reportSDoc "tc.lhs.unify" 40 $ "fj = " <+> text (show fj)+       reportSDoc "tc.lhs.unify" 40 $ "chooseFlex: " <+> text (show choice)        case choice of          ChooseLeft   -> firstTryLeft          ChooseRight  -> firstTryRight@@ -666,12 +680,13 @@  dataStrategy :: Int -> UnifyStrategy dataStrategy k s = do-  Equal Dom{unDom = a} u v <- liftTCM $ eqConstructorForm =<< eqUnLevel =<< reduce (getEqualityUnraised k s)+  Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< reduce (getEqualityUnraised k s)+  sa <- reduce $ getSort a   case unEl a of-    Def d es | Type{} <- getSort a -> do-      npars <- catMaybesMP $ liftTCM $ getNumberOfParameters d+    Def d es | Type{} <- sa -> do+      npars <- catMaybesMP $ getNumberOfParameters d       let (pars,ixs) = splitAt npars $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      liftTCM $ reportSDoc "tc.lhs.unify" 40 $ addContext (varTel s `abstract` eqTel s) $+      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)       case (u, v) of@@ -685,7 +700,7 @@     ifOccursStronglyRigid i u ret = do         -- Call forceNotFree to reduce u as far as possible         -- around any occurrences of i-        (_ , u) <- liftTCM $ forceNotFree (singleton i) u+        (_ , u) <- forceNotFree (singleton i) u         case flexRigOccurrenceIn i u of           Just StronglyRigid -> ret           _ -> mzero@@ -700,8 +715,9 @@ literalStrategy :: Int -> UnifyStrategy literalStrategy k s = do   let n = eqCount s-  Equal Dom{unDom = a} u v <- liftTCM $ eqUnLevel $ getEquality k s+  Equal Dom{unDom = a} u v <- eqUnLevel $ getEquality k s   ha <- fromMaybeMP $ isHom n a+  (u, v) <- reduce (u, v)   case (u , v) of     (Lit l1 , Lit l2)      | l1 == l2  -> return $ Deletion k ha u v@@ -710,30 +726,30 @@  etaExpandVarStrategy :: Int -> UnifyStrategy etaExpandVarStrategy k s = do-  Equal Dom{unDom = a} u v <- liftTCM $ eqUnLevel <=< reduce $ getEquality k s+  Equal Dom{unDom = a} u v <- eqUnLevel <=< reduce $ getEquality 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     shouldEtaExpand :: Term -> Term -> Type -> UnifyStrategy     shouldEtaExpand (Var i es) v a s = do       fi       <- fromMaybeMP $ findFlexible i (flexVars s)-      liftTCM $ reportSDoc "tc.lhs.unify" 50 $+      reportSDoc "tc.lhs.unify" 50 $         "Found flexible variable " <+> text (show i)       -- Issue 2888: Do this if there are only projections or if it's a singleton       -- record or if it's unified against a record constructor term. Basically       -- we need to avoid EtaExpandEquation if EtaExpandVar is possible, or the       -- forcing translation is unhappy.       b         <- reduce $ unDom $ getVarTypeUnraised (varCount s - 1 - i) s-      (d, pars) <- catMaybesMP $ liftTCM $ isEtaRecordType b+      (d, pars) <- catMaybesMP $ isEtaRecordType b       ps        <- fromMaybeMP $ allProjElims es       guard =<< orM         [ pure $ not $ null ps-        , liftTCM $ isRecCon v  -- is the other term a record constructor?-        , liftTCM $ (Right True ==) <$> isSingletonRecord d pars+        , isRecCon v  -- is the other term a record constructor?+        , (Right True ==) <$> runBlocked (isSingletonRecord d pars)         ]-      liftTCM $ reportSDoc "tc.lhs.unify" 50 $+      reportSDoc "tc.lhs.unify" 50 $         "with projections " <+> prettyTCM (map snd ps)-      liftTCM $ reportSDoc "tc.lhs.unify" 50 $+      reportSDoc "tc.lhs.unify" 50 $         "at record type " <+> prettyTCM d       return $ EtaExpandVar fi d pars     shouldEtaExpand _ _ _ _ = mzero@@ -745,16 +761,16 @@ etaExpandEquationStrategy k s = do   -- Andreas, 2019-02-23, re #3578, is the following reduce redundant?   Equal Dom{unDom = a} u v <- reduce $ getEqualityUnraised k s-  (d, pars) <- catMaybesMP $ liftTCM $ addContext tel $ isEtaRecordType a+  (d, pars) <- catMaybesMP $ addContext tel $ isEtaRecordType a   guard =<< orM-    [ liftTCM $ (Right True ==) <$> isSingletonRecord d pars-    , liftTCM $ shouldProject u-    , liftTCM $ shouldProject v+    [ (Right True ==) <$> runBlocked (isSingletonRecord d pars)+    , shouldProject u+    , shouldProject v     ]   return $ EtaExpandEquation k d pars   where-    shouldProject :: Term -> TCM Bool-    shouldProject u = case u of+    shouldProject :: PureTCM m => Term -> m Bool+    shouldProject = \case       Def f es   -> usesCopatterns f       Con c _ _  -> isJust <$> isRecordConstructor (conName c) @@ -772,13 +788,13 @@  simplifySizesStrategy :: Int -> UnifyStrategy simplifySizesStrategy k s = do-  isSizeName <- liftTCM isSizeNameTest+  isSizeName <- isSizeNameTest   Equal Dom{unDom = a} u v <- reduce $ getEquality k s   case unEl a of     Def d _ -> do       guard $ isSizeName d-      su <- liftTCM $ sizeView u-      sv <- liftTCM $ sizeView v+      su <- sizeView u+      sv <- sizeView v       case (su, sv) of         (SizeSuc u, SizeSuc v) -> return $ StripSizeSuc k u v         (SizeSuc u, SizeInf  ) -> return $ StripSizeSuc k u v@@ -788,13 +804,13 @@  injectiveTypeConStrategy :: Int -> UnifyStrategy injectiveTypeConStrategy k s = do-  injTyCon <- liftTCM $ optInjectiveTypeConstructors <$> pragmaOptions+  injTyCon <- optInjectiveTypeConstructors <$> pragmaOptions   guard injTyCon-  eq <- liftTCM $ eqUnLevel <=< reduce $ getEquality k s+  eq <- eqUnLevel <=< reduce $ getEquality k s   case eq of     Equal a u@(Def d es) v@(Def d' es') | d == d' -> do       -- d must be a data, record or axiom-      def <- liftTCM $ getConstInfo d+      def <- getConstInfo d       guard $ case theDef def of                 Datatype{} -> True                 Record{}   -> True@@ -803,6 +819,7 @@                 AbstractDefn{} -> False -- True triggers issue #2250                 Function{}   -> False                 Primitive{}  -> False+                PrimitiveSort{} -> __IMPOSSIBLE__                 GeneralizableVar{} -> __IMPOSSIBLE__                 Constructor{} -> __IMPOSSIBLE__  -- Never a type!       let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -812,11 +829,11 @@  injectivePragmaStrategy :: Int -> UnifyStrategy injectivePragmaStrategy k s = do-  eq <- liftTCM $ eqUnLevel <=< reduce $ getEquality k s+  eq <- eqUnLevel <=< reduce $ getEquality 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 <- liftTCM $ getConstInfo d+      def <- getConstInfo d       guard $ defInjective def       let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es           vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es'@@ -825,8 +842,9 @@  skipIrrelevantStrategy :: Int -> UnifyStrategy skipIrrelevantStrategy k s = do-  let Equal a _ _ = getEquality k s  -- reduce not necessary-  guard =<< isIrrelevantOrPropM a    -- reduction takes place here+  let Equal a _ _ = getEquality k s                               -- reduce not necessary+  guard . (== Right True) =<< runBlocked (isIrrelevantOrPropM a)  -- reduction takes place here+  -- TODO: do something in case the above is blocked (i.e. `Left b`)   return $ SkipIrrelevantEquation k  @@ -857,53 +875,55 @@   mempty  = UnifyOutput IdS IdS []   mappend = (<>) -type UnifyM a = WriterT UnifyOutput TCM a+type UnifyLogT m a = WriterT UnifyOutput m a -tellUnifySubst :: PatternSubstitution -> UnifyM ()+tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m () tellUnifySubst sub = tell $ UnifyOutput sub IdS [] -tellUnifyProof :: PatternSubstitution -> UnifyM ()+tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m () tellUnifyProof sub = tell $ UnifyOutput IdS sub [] -writeUnifyLog :: UnifyLogEntry -> UnifyM ()+writeUnifyLog :: MonadWriter UnifyOutput m => UnifyLogEntry -> m () writeUnifyLog x = tell $ UnifyOutput IdS IdS [x] -runUnifyM :: UnifyM a -> TCM (a,UnifyOutput)-runUnifyM = runWriterT+runUnifyLogT :: UnifyLogT m a -> m (a,UnifyOutput)+runUnifyLogT = runWriterT -unifyStep :: UnifyState -> UnifyStep -> UnifyM (UnificationResult' UnifyState)+unifyStep+  :: (PureTCM m, MonadWriter UnifyOutput m)+  => UnifyState -> UnifyStep -> m (UnificationResult' UnifyState)  unifyStep s Deletion{ deleteAt = k , deleteType = a , deleteLeft = u , deleteRight = v } = do     -- Check definitional equality of u and v-    isReflexive <- liftTCM $ addContext (varTel s) $ tryCatch $ do-      dontAssignMetas $ noConstraints $ equalTerm a u v-    withoutK <- liftTCM withoutKOption+    isReflexive <- addContext (varTel s) $ runBlocked $ pureEqualTerm a u v+    withoutK <- withoutKOption+    splitOnStrict <- asksTC envSplitOnStrict     case isReflexive of-      Just err     -> return $ DontKnow []-      _ | withoutK -> return $ DontKnow [UnifyReflexiveEq (varTel s) a u]-      _            -> do+      Left block   -> return $ UnifyBlocked block+      Right False  -> return $ UnifyStuck []+      Right True | withoutK && not splitOnStrict+                   -> return $ UnifyStuck [UnifyReflexiveEq (varTel s) a u]+      Right True   -> do         let (s', sigma) = solveEq k u s         tellUnifyProof sigma-        Unifies <$> liftTCM (lensEqTel reduce s')+        Unifies <$> lensEqTel reduce s'  unifyStep s step@Solution{} = solutionStep RetryNormalised s step  unifyStep s (Injectivity k a d pars ixs c) = do-  ifM (liftTCM $ consOfHIT $ conName c) (return $ DontKnow []) $ do-  withoutK <- liftTCM withoutKOption-  let n = eqCount s+  ifM (consOfHIT $ conName c) (return $ UnifyStuck []) $ do+  withoutK <- withoutKOption    -- Split equation telescope into parts before and after current equation   let (eqListTel1, _ : eqListTel2) = splitAt k $ telToList $ eqTel s       (eqTel1, eqTel2) = (telFromList eqListTel1, telFromList eqListTel2)    -- Get constructor telescope and target indices-  cdef  <- liftTCM (getConInfo c)+  cdef  <- getConInfo c   let ctype  = defType cdef `piApply` pars-      forced = defForced cdef   addContext (varTel s `abstract` eqTel1) $ reportSDoc "tc.lhs.unify" 40 $     "Constructor type: " <+> prettyTCM ctype-  TelV ctel ctarget <- liftTCM $ telView ctype+  TelV ctel ctarget <- telView ctype   let cixs = case unEl ctarget of                Def d' es | d == d' ->                  let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -911,7 +931,7 @@                _ -> __IMPOSSIBLE__    -- Get index telescope of the datatype-  dtype    <- (`piApply` pars) . defType <$> liftTCM (getConstInfo d)+  dtype    <- (`piApply` pars) . defType <$> getConstInfo d   addContext (varTel s `abstract` eqTel1) $ reportSDoc "tc.lhs.unify" 40 $     "Datatype type: " <+> prettyTCM dtype @@ -923,7 +943,7 @@   -- computeNeighbourhood function in Agda.TypeChecking.Coverage.   let hduTel = eqTel1 `abstract` ctel       notforced = replicate (size hduTel) NotForced-  res <- liftTCM $ addContext (varTel s) $ unifyIndices+  res <- addContext (varTel s) $ unifyIndices'            hduTel            (allFlexVars notforced hduTel)            (raise (size ctel) dtype)@@ -935,10 +955,13 @@     -- same type for distinct constructors c1 and c2.     NoUnify _ -> __IMPOSSIBLE__ +    -- Higher-dimensional unification is blocked: propagate+    UnifyBlocked block -> return $ UnifyBlocked block+     -- Higher-dimensional unification has failed. If not --without-K,     -- we can simply ignore the higher-dimensional equations and     -- simplify the equation as in the non-indexed case.-    DontKnow _ | not withoutK -> do+    UnifyStuck _ | not withoutK -> do       -- using the same variable names as in the case where hdu succeeds.       let eqTel1' = eqTel1 `abstract` ctel           rho1    = raiseS (size ctel)@@ -950,13 +973,13 @@        tellUnifyProof rho -      eqTel' <- liftTCM $ reduce eqTel'+      eqTel' <- reduce eqTel'        -- Compute new lhs and rhs by matching the old ones against rho       (lhs', rhs') <- do         let ps = applySubst rho $ teleNamedArgs $ eqTel s-        (lhsMatch, _) <- liftTCM $ runReduceM $ Match.matchPatterns ps $ eqLHS s-        (rhsMatch, _) <- liftTCM $ runReduceM $ Match.matchPatterns ps $ eqRHS s+        (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s+        (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s         case (lhsMatch, rhsMatch) of           (Match.Yes _ lhs', Match.Yes _ rhs') -> return             (reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') lhs',@@ -966,11 +989,11 @@       return $ Unifies $ s { eqTel = eqTel' , eqLHS = lhs' , eqRHS = rhs' }  -    DontKnow _ -> let n           = eqCount s-                      Equal Dom{unDom = a} u v = getEquality k s-                  in return $ DontKnow [UnifyIndicesNotVars-                       (varTel s `abstract` eqTel s) a-                       (raise n u) (raise n v) (raise (n-k) ixs)]+    UnifyStuck _ -> let n           = eqCount s+                        Equal Dom{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)]      Unifies (eqTel1', rho0, _) -> do       -- Split ps0 into parts for eqTel1 and ctel@@ -985,13 +1008,13 @@        tellUnifyProof rho -      eqTel' <- liftTCM $ reduce eqTel'+      eqTel' <- reduce eqTel'        -- Compute new lhs and rhs by matching the old ones against rho       (lhs', rhs') <- do         let ps = applySubst rho $ teleNamedArgs $ eqTel s-        (lhsMatch, _) <- liftTCM $ runReduceM $ Match.matchPatterns ps $ eqLHS s-        (rhsMatch, _) <- liftTCM $ runReduceM $ Match.matchPatterns ps $ eqRHS s+        (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s+        (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s         case (lhsMatch, rhsMatch) of           (Match.Yes _ lhs', Match.Yes _ rhs') -> return             (reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') lhs',@@ -1006,7 +1029,7 @@   } =   case u of     Con h _ _ -> do-      ifM (liftTCM $ consOfHIT $ conName h) (return $ DontKnow []) $ do+      ifM (consOfHIT $ conName h) (return $ UnifyStuck []) $ do         return $ NoUnify $ UnifyConflict (varTel s) u v     _ -> __IMPOSSIBLE__ unifyStep s Cycle@@ -1015,13 +1038,14 @@   } =   case u of     Con h _ _ -> do-      ifM (liftTCM $ consOfHIT $ conName h) (return $ DontKnow []) $ do+      ifM (consOfHIT $ conName h) (return $ UnifyStuck []) $ do         return $ NoUnify $ UnifyCycle (varTel s) i u     _ -> __IMPOSSIBLE__  unifyStep s EtaExpandVar{ expandVar = fi, expandVarRecordType = d , expandVarParameters = pars } = do-  delta   <- liftTCM $ (`apply` pars) <$> getRecordFieldTypes d-  c       <- liftTCM $ getRecordConstructor d+  recd <- fromMaybe __IMPOSSIBLE__ <$> isRecord d+  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] ]@@ -1036,7 +1060,6 @@   where     i = flexVar fi     m = varCount s-    n = eqCount s      projFlexKind :: Int -> FlexibleVarKind     projFlexKind j = case flexKind fi of@@ -1052,14 +1075,15 @@     liftFlexibles n fs = mapMaybe (traverse $ liftFlexible n) fs  unifyStep s EtaExpandEquation{ expandAt = k, expandRecordType = d, expandParameters = pars } = do-  delta <- liftTCM $ (`apply` pars) <$> getRecordFieldTypes d-  c     <- liftTCM $ getRecordConstructor d+  recd  <- fromMaybe __IMPOSSIBLE__ <$> isRecord d+  let delta = recTel recd `apply` pars+      c     = recConHead recd   lhs   <- expandKth $ eqLHS s   rhs   <- expandKth $ eqRHS s   let (tel, sigma) = expandTelescopeVar (eqTel s) k delta c   tellUnifyProof sigma   Unifies <$> do-   liftTCM $ lensEqTel reduce $ s+   lensEqTel reduce $ s     { eqTel    = tel     , eqLHS    = lhs     , eqRHS    = rhs@@ -1067,8 +1091,8 @@   where     expandKth us = do       let (us1,v:us2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt k us-      vs <- liftTCM $ snd <$> etaExpandRecord d pars (unArg v)-      vs <- liftTCM $ reduce vs+      vs <- snd <$> etaExpandRecord d pars (unArg v)+      vs <- reduce vs       return $ us1 ++ vs ++ us2  unifyStep s LitConflict@@ -1078,8 +1102,8 @@   } = return $ NoUnify $ UnifyConflict (varTel s) (Lit l) (Lit l')  unifyStep s (StripSizeSuc k u v) = do-  sizeTy <- liftTCM sizeType-  sizeSu <- liftTCM $ sizeSuc 1 (var 0)+  sizeTy <- sizeType+  sizeSu <- sizeSuc 1 (var 0)   let n          = eqCount s       sub        = liftS (n-k-1) $ consS sizeSu $ raiseS 1       eqFlatTel  = flattenTel $ eqTel s@@ -1100,15 +1124,13 @@   return $ Unifies s'  unifyStep s (TypeConInjectivity k d us vs) = do-  dtype <- defType <$> liftTCM (getConstInfo d)-  TelV dtel _ <- liftTCM $ telView dtype-  let n   = eqCount s-      m   = size dtel-      deq = Def d $ map Apply $ teleArgs dtel+  dtype <- defType <$> getConstInfo d+  TelV dtel _ <- telView dtype+  let deq = Def d $ map Apply $ teleArgs dtel   -- TODO: tellUnifyProof ???   -- but d is not a constructor...   Unifies <$> do-   liftTCM $ lensEqTel reduce $ s+   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)@@ -1117,7 +1139,12 @@ data RetryNormalised = RetryNormalised | DontRetryNormalised   deriving (Eq, Show) -solutionStep :: RetryNormalised -> UnifyState -> UnifyStep -> UnifyM (UnificationResult' UnifyState)+solutionStep+  :: (PureTCM m, MonadWriter UnifyOutput m)+  => RetryNormalised+  -> UnifyState+  -> UnifyStep+  -> m (UnificationResult' UnifyState) solutionStep retry s   step@Solution{ solutionAt   = k                , solutionType = dom@Dom{ unDom = a }@@ -1138,19 +1165,19 @@   (p, bound) <- patternBindingForcedVars forcedVars u    -- To maintain the invariant that each variable in varTel is bound exactly once in the pattern-  -- subtitution we need to turn the bound variables in `p` into dot patterns in the rest of the+  -- substitution we need to turn the bound variables in `p` into dot patterns in the rest of the   -- substitution.   let dotSub = foldr composeS idS [ inplaceS i (dotP (Var i [])) | i <- IntMap.keys bound ]    -- We moved the binding site of some forced variables, so we need to update their modalities in   -- the telescope. The new modality is the combination of the modality of the variable we are-  -- instantiating and the modality of the binding site in the pattern (return by+  -- instantiating and the modality of the binding site in the pattern (returned by   -- patternBindingForcedVars).   let updModality md vars tel         | IntMap.null vars = tel         | otherwise        = telFromList $ zipWith upd (downFrom $ size tel) (telToList tel)         where-          upd i a | Just md' <- IntMap.lookup i vars = setModality (md <> md') a+          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) } @@ -1164,10 +1191,10 @@   -- 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-  equalTypes <- liftTCM $ addContext (varTel s) $ tryCatch $ do+  equalTypes <- addContext (varTel s) $ runBlocked $ do     reportSDoc "tc.lhs.unify" 45 $ "Equation type: " <+> prettyTCM a     reportSDoc "tc.lhs.unify" 45 $ "Variable type: " <+> prettyTCM a'-    dontAssignMetas $ noConstraints $ equalType a a'+    pureEqualType 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@@ -1192,24 +1219,28 @@   -- and thus, in quantity 0, that get into terms using the unifier, and there are checked to be   -- non-erased, i.e., have quantity ω.   -- Ulf, 2019-12-13. We still do it though.-  usable <- liftTCM $ addContext (varTel s) $ usableMod mod u+  -- Andrea, 2020-10-15: It looks at meta instantiations now.+  eusable <- addContext (varTel s) $ runExceptT $ usableMod mod u+  caseEitherM (return eusable) (return . UnifyBlocked) $ \ usable -> do+   reportSDoc "tc.lhs.unify" 45 $ "Modality ok: " <+> prettyTCM usable   unless usable $ reportSLn "tc.lhs.unify" 65 $ "Rejected solution: " ++ show u    -- We need a Flat equality to solve a Flat variable.   -- This also ought to take care of the need for a usableCohesion check.-  if not (getCohesion eqmod `moreCohesion` getCohesion varmod) then return $ DontKnow [] else do+  if not (getCohesion eqmod `moreCohesion` getCohesion varmod) then return $ UnifyStuck [] else do    case equalTypes of-    Just err -> return $ DontKnow []-    Nothing | usable ->+    Left block  -> return $ UnifyBlocked block+    Right False -> return $ UnifyStuck []+    Right True | usable ->       case solveVar (m - 1 - i) p s of         Nothing | retry == RetryNormalised -> do-          u <- liftTCM $ normalise u-          s <- liftTCM $ lensVarTel normalise s+          u <- normalise u+          s <- lensVarTel normalise s           solutionStep DontRetryNormalised s step{ solutionTerm = u }         Nothing ->-          return $ DontKnow [UnifyRecursiveEq (varTel s) a i u]+          return $ UnifyStuck [UnifyRecursiveEq (varTel s) a i u]         Just (s', sub) -> do           let rho = sub `composeS` dotSub           tellUnifySubst rho@@ -1218,25 +1249,31 @@           return $ Unifies s''           -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce           -- Unifies <$> liftTCM (reduce s'')-    Nothing -> return $ DontKnow [UnifyUnusableModality (varTel s) a i u mod]+    Right True -> return $ UnifyStuck [UnifyUnusableModality (varTel s) a i u mod] solutionStep _ _ _ = __IMPOSSIBLE__ -unify :: UnifyState -> UnifyStrategy -> UnifyM (UnificationResult' UnifyState)+unify+  :: (PureTCM m, MonadWriter UnifyOutput m)+  => UnifyState -> UnifyStrategy -> m (UnificationResult' UnifyState) unify s strategy = if isUnifyStateSolved s                    then return $ Unifies s                    else tryUnifyStepsAndContinue (strategy s)   where-    tryUnifyStepsAndContinue :: ListT TCM UnifyStep -> UnifyM (UnificationResult' UnifyState)+    tryUnifyStepsAndContinue+      :: (PureTCM m, MonadWriter UnifyOutput m)+      => ListT m UnifyStep -> m (UnificationResult' UnifyState)     tryUnifyStepsAndContinue steps = do-      x <- foldListT tryUnifyStep failure $ liftListT lift steps+      x <- foldListT tryUnifyStep failure steps       case x of-        Unifies s'   -> unify s' strategy-        NoUnify err  -> return $ NoUnify err-        DontKnow err -> return $ DontKnow err+        Unifies s'     -> unify s' strategy+        NoUnify err    -> return $ NoUnify err+        UnifyBlocked b -> return $ UnifyBlocked b+        UnifyStuck err -> return $ UnifyStuck err -    tryUnifyStep :: UnifyStep-                 -> UnifyM (UnificationResult' UnifyState)-                 -> UnifyM (UnificationResult' UnifyState)+    tryUnifyStep :: (PureTCM m, MonadWriter UnifyOutput m)+                 => UnifyStep+                 -> m (UnificationResult' UnifyState)+                 -> m (UnificationResult' UnifyState)     tryUnifyStep step fallback = do       addContext (varTel s) $         reportSDoc "tc.lhs.unify" 20 $ "trying unifyStep" <+> prettyTCM step@@ -1247,24 +1284,30 @@           reportSDoc "tc.lhs.unify" 20 $ "new unifyState:" <+> prettyTCM s'           writeUnifyLog $ UnificationStep s step           return x-        NoUnify{}     -> return x-        DontKnow err1 -> do+        NoUnify{}       -> return x+        UnifyBlocked b1 -> do           y <- fallback           case y of-            DontKnow err2 -> return $ DontKnow $ err1 ++ err2-            _             -> return y+            UnifyStuck _    -> return $ UnifyBlocked b1+            UnifyBlocked b2 -> return $ UnifyBlocked $ unblockOnEither b1 b2+            _               -> return y+        UnifyStuck err1 -> do+          y <- fallback+          case y of+            UnifyStuck err2 -> return $ UnifyStuck $ err1 ++ err2+            _               -> return y -    failure :: UnifyM (UnificationResult' a)-    failure = return $ DontKnow []+    failure :: Monad m => m (UnificationResult' a)+    failure = return $ UnifyStuck [] --- | Turn a term into a pattern binding as many of the given forced variables as possible (in+-- | Turn a term into a pattern while binding as many of the given forced variables as possible (in --   non-forced positions).-patternBindingForcedVars :: (HasConstInfo m, MonadReduce m) => IntMap Modality -> Term -> m (DeBruijnPattern, IntMap Modality)+patternBindingForcedVars :: PureTCM m => IntMap Modality -> Term -> m (DeBruijnPattern, IntMap Modality) patternBindingForcedVars forced v = do   let v' = precomputeFreeVars_ v   runWriterT (evalStateT (go defaultModality v') forced)   where-    noForced v = IntSet.null . IntSet.intersection (precomputedFreeVars v) . IntMap.keysSet <$> get+    noForced v = gets $ IntSet.disjoint (precomputedFreeVars v) . IntMap.keysSet      bind md i = do       Just md' <- gets $ IntMap.lookup i@@ -1283,13 +1326,12 @@           | Just vs <- allApplyElims es -> do             fs <- defForced <$> getConstInfo (conName c)             let goArg Forced    v = return $ fmap (unnamed . dotP) v-                goArg NotForced v = fmap unnamed <$> traverse (go $ md <> getModality v) v+                goArg NotForced v = fmap unnamed <$> traverse (go $ composeModality md $ getModality v) v             (ps, bound) <- listen $ zipWithM goArg (fs ++ repeat NotForced) vs             if IntMap.null bound               then return $ dotP v  -- bound nothing               else do-                let cpi = (toConPatternInfo ci) { conPRecord = True,-                                                  conPLazy   = True } -- Not setting conPType. Is this a problem?+                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)

src/full/Agda/TypeChecking/Rules/Record.hs view

@@ -6,6 +6,7 @@  import Control.Monad import Data.Maybe+import qualified Data.Set as Set  import Agda.Interaction.Options @@ -17,7 +18,6 @@ import qualified Agda.Syntax.Info as Info  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Primitive import Agda.TypeChecking.Rewriting.Confluence import Agda.TypeChecking.Substitute@@ -26,6 +26,7 @@ import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Pretty import Agda.TypeChecking.Polarity+import Agda.TypeChecking.Warnings import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.CompiledClause (hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile@@ -40,8 +41,10 @@ import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Utils.POMonoid+import Agda.Utils.Pretty (render) import qualified Agda.Utils.Pretty as P import Agda.Utils.Size+import Agda.Utils.WithDefault  import Agda.Utils.Impossible @@ -66,15 +69,13 @@   :: A.DefInfo                 -- ^ Position and other info.   -> QName                     -- ^ Record type identifier.   -> UniverseCheck             -- ^ Check universes?-  -> Maybe (Ranged Induction)  -- ^ Optional: (co)inductive declaration.-  -> Maybe HasEta              -- ^ Optional: user specified eta/no-eta-  -> Maybe QName               -- ^ Optional: constructor name.+  -> A.RecordDirectives        -- ^ (Co)Inductive, (No)Eta, (Co)Pattern, Constructor?   -> A.DataDefParams           -- ^ Record parameters.   -> A.Expr                    -- ^ Approximate type of constructor (@fields@ -> Set).                                --   Does not include record parameters.   -> [A.Field]                 -- ^ Field signatures.   -> TCM ()-checkRecDef i name uc ind eta con (A.DataDefParams gpars ps) contel fields =+checkRecDef i name uc (RecordDirectives ind eta0 pat con) (A.DataDefParams gpars ps) contel fields =   traceCall (CheckRecDef (getRange name) name ps fields) $ do     reportSDoc "tc.rec" 10 $ vcat       [ "checking record def" <+> prettyTCM name@@ -136,12 +137,16 @@         -- NB: contype does not contain the parameter telescope        -- Obtain name of constructor (if present).-      (hasNamedCon, conName, conInfo) <- case con of-        Just c  -> return (True, c, i)+      (hasNamedCon, conName) <- case con of+        Just c  -> return (True, c)         Nothing -> do           m <- killRange <$> currentModule-          c <- qualify m <$> freshName_ ("recCon-NOT-PRINTED" :: String)-          return (False, c, i)+          -- Andreas, 2020-06-01, AIM XXXII+          -- Using prettyTCM here jinxes the printer, see PR #4699.+          -- r <- prettyTCM name+          let r = P.pretty $ qnameName name+          c <- qualify m <$> freshName_ (render r ++ ".constructor")+          return (False, c)        -- Add record type to signature.       reportSDoc "tc.rec" 15 $ "adding record type to signature"@@ -165,18 +170,18 @@           -- 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.-          haveEta      = maybe (Inferred NoEta) Specified eta+          haveEta      = maybe (Inferred $ NoEta patCopat) Specified eta           -- haveEta      = maybe (Inferred $ conInduction == Inductive && etaenabled) Specified eta-          con = ConHead conName conInduction $ map argFromDom fs+          con = ConHead conName (IsRecord patCopat) conInduction $ map argFromDom fs            -- A record is irrelevant if all of its fields are.           -- In this case, the associated module parameter will be irrelevant.           -- See issue 392.           -- Unless it's been declared coinductive or no-eta-equality (#2607).           recordRelevance-            | eta          == Just NoEta  = Relevant-            | conInduction == CoInductive = Relevant-            | otherwise                   = minimum $ Irrelevant : (map getRelevance $ telToList ftel)+            | Just NoEta{} <- eta         = Relevant+            | CoInductive <- conInduction = Relevant+            | otherwise                   = minimum $ Irrelevant : map getRelevance (telToList ftel)        -- Andreas, 2017-01-26, issue #2436       -- Disallow coinductive records with eta-equality@@ -188,6 +193,13 @@               ]       reportSDoc "tc.rec" 30 $ "record constructor is " <+> prettyTCM con +      -- Jesper, 2021-05-26: Warn when declaring coinductive record+      -- but neither --guardedness nor --sized-types is enabled.+      when (conInduction == CoInductive) $ do+        guardedness <- collapseDefault . optGuardedness <$> pragmaOptions+        sizedTypes  <- collapseDefault . optSizedTypes  <$> pragmaOptions+        unless (guardedness || sizedTypes) $ warning $ NoGuardednessFlag name+       -- Add the record definition.        -- Andreas, 2016-06-17, Issue #2018:@@ -197,7 +209,7 @@       -- we make sure we get the original names!       let npars = size tel           telh  = fmap hideAndRelParams tel-      escapeContext __IMPOSSIBLE__ npars $ do+      escapeContext impossible npars $ do         addConstant name $           defaultDefn defaultArgInfo name t $             Record@@ -209,6 +221,7 @@               , recTel            = telh `abstract` ftel               , 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.@@ -225,7 +238,7 @@               , conArity  = size fs               , conSrcCon = con               , conData   = name-              , conAbstr  = Info.defAbstract conInfo+              , conAbstr  = Info.defAbstract i               , conInd    = conInduction               , conComp   = emptyCompKit  -- filled in later               , conProj   = Nothing       -- filled in later@@ -302,7 +315,7 @@             ]           ]         reportSDoc "tc.rec.def" 15 $ nest 2 $ vcat-          [ "field tel =" <+> escapeContext __IMPOSSIBLE__ 1 (prettyTCM ftel)+          [ "field tel =" <+> escapeContext impossible 1 (prettyTCM ftel)           ]         addSection m @@ -321,20 +334,26 @@           -- See test/Succeed/ProjectionsTakeModuleTelAsParameters.agda.           tel' <- getContextTelescope           setModuleCheckpoint m-          checkRecordProjections m name hasNamedCon con tel' (raise 1 ftel) fields+          checkRecordProjections m name hasNamedCon con tel' ftel fields         -- we define composition here so that the projections are already in the signature.-      escapeContext __IMPOSSIBLE__ npars $ do+      escapeContext impossible npars $ do         addCompositionForRecord name con tel (map argFromDom fs) ftel rect -      -- Jesper, 2019-06-07: Check confluence of projection clauses-      whenM (optConfluenceCheck <$> pragmaOptions) $ forM_ fs $ \f -> do-        cls <- defClauses <$> getConstInfo (unDom f)-        forM (zip cls [0..]) $ \(cl,i) ->-          checkConfluenceOfClause (unDom f) i cl+      -- The confluence checker needs to know what symbols match against+      -- the constructor.+      modifySignature $ updateDefinition conName $ \def ->+        def { defMatchable = Set.fromList $ map unDom fs }        return ()+  where+  -- Andreas, 2020-04-19, issue #4560+  -- If the user declared the record constructor as @pattern@,+  -- 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 <$) <$> eta0   addCompositionForRecord@@ -420,7 +439,7 @@            io <- primIOne            Just io_name <- getBuiltinName' builtinIOne            one <- primItIsOne-           tInterval <- elInf primInterval+           tInterval <- primIntervalType            let               (ix,rhs) =                 case cmd of@@ -435,7 +454,7 @@                   -- body = u i1 itIsOne                   DoHComp  -> (2,Var 1 [] `apply` [argN io, setRelevance Irrelevant $ argN one]) -              p = ConP (ConHead io_name Inductive [])+              p = ConP (ConHead io_name IsData Inductive [])                        (noConPatternInfo { conPType = Just (Arg defaultArgInfo tInterval)                                          , conPFallThrough = True })                          []@@ -463,13 +482,14 @@                          , clauseLHSRange  = noRange                          , clauseCatchall  = False                          , clauseBody      = Just $ rhs+                         , clauseExact       = Just True                          , clauseRecursive   = Just False  -- definitely non-recursive!                          , clauseUnreachable = Just False                          , clauseEllipsis  = NoEllipsis                          }            reportSDoc "trans.rec.face" 17 $ text $ show c            return c-  cs <- flip mapM (zip3 fns clause_types bodies) $ \ (fname, clause_ty, body) -> do+  cs <- forM (zip3 fns clause_types bodies) $ \ (fname, clause_ty, body) -> do           let               pats = teleNamedArgs gamma ++ [defaultNamedArg $ ProjP ProjSystem $ unArg fname]               c = Clause { clauseTel       = gamma@@ -479,6 +499,7 @@                          , clauseLHSRange  = noRange                          , clauseCatchall  = False                          , clauseBody      = Just body+                         , clauseExact       = Just True                          , clauseRecursive   = Nothing                              -- Andreas 2020-02-06 TODO                              -- Or: Just False;  is it known to be non-recursive?@@ -517,18 +538,18 @@   ModuleName -> QName -> Bool -> ConHead -> Telescope -> Telescope ->   [A.Declaration] -> TCM () checkRecordProjections m r hasNamedCon con tel ftel fs = do-    checkProjs EmptyTel ftel fs+    checkProjs EmptyTel ftel [] fs   where -    checkProjs :: Telescope -> Telescope -> [A.Declaration] -> TCM ()+    checkProjs :: Telescope -> Telescope -> [Term] -> [A.Declaration] -> TCM () -    checkProjs _ _ [] = return ()+    checkProjs _ _ _ [] = return () -    checkProjs ftel1 ftel2 (A.ScopedDecl scope fs' : fs) =-      setScope scope >> checkProjs ftel1 ftel2 (fs' ++ fs)+    checkProjs ftel1 ftel2 vs (A.ScopedDecl scope fs' : fs) =+      setScope scope >> checkProjs ftel1 ftel2 vs (fs' ++ fs)      -- Case: projection.-    checkProjs ftel1 (ExtendTel (dom@Dom{domInfo = ai,unDom = t}) ftel2) (A.Field info x _ : fs) =+    checkProjs ftel1 (ExtendTel (dom@Dom{domInfo = ai,unDom = t}) ftel2) vs (A.Field info x _ : fs) =       traceCall (CheckProjection (getRange info) x t) $ do       -- Andreas, 2012-06-07:       -- Issue 387: It is wrong to just type check field types again@@ -539,14 +560,26 @@         , nest 2 $ vcat           [ "top   =" <+> (inTopContext . prettyTCM =<< getContextTelescope)           , "tel   =" <+> (inTopContext . prettyTCM $ tel)-          , "ftel1 =" <+> prettyTCM ftel1-          , "t     =" <+> prettyTCM t-          , "ftel2 =" <+> addContext ftel1 (underAbstraction_ ftel2 prettyTCM)+          ]+        ]+      -- Andreas, 2021-05-11, issue #5378+      -- The impossible is sometimes possible, so splitting out this part...+      reportSDoc "tc.rec.proj" 5 $ 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" 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)           , "abstr =" <+> (text . show) (Info.defAbstract info)           , "quant =" <+> (text . show) (getQuantity ai)           , "coh   =" <+> (text . show) (getCohesion ai)           ]-        ]        -- Cohesion check:       -- For a field `@c π : A` we would create a projection `π : .., (@(c^-1) r : R as) -> A`@@ -554,14 +587,13 @@       --       -- Alternatively we could create a projection `.. |- π r :c A`       -- but that would require support for a `t :c A` judgment.-      if hasLeftAdjoint (getCohesion ai)+      if hasLeftAdjoint (UnderComposition (getCohesion ai))         then unless (getCohesion ai == Continuous)                     -- Andrea TODO: properly update the context/type of the projection when we add Sharp                     __IMPOSSIBLE__         else genericError $ "Cannot have record fields with modality " ++ show (getCohesion ai) -      -- Andreas, 2010-09-09 The following comments are misleading, TODO: update-      -- in fact, tel includes the variable of record type as last one+      -- The telescope tel includes the variable of record type as last one       -- e.g. for cartesion product it is       --       --   tel = {A' : Set} {B' : Set} (r : Prod A' B')@@ -569,24 +601,28 @@       -- create the projection functions (instantiate the type with the values       -- of the previous fields) +      -- The type of the projection function should be+      --  {Δ} -> (r : R Δ) -> t+      -- where Δ are the parameters of R+       {- what are the contexts? -          Γ, tel            ⊢ t-          Γ, tel, r         ⊢ vs-          Γ, tel, r, ftel₁  ⊢ raiseFrom (size ftel₁) 1 t+          Δ , ftel₁              ⊢ t+          Δ , (r : R Δ)          ⊢ parallelS vs : ftel₁+          Δ , (r : R Δ) , ftel₁  ⊢ t' = raiseFrom (size ftel₁) 1 t+          Δ , (r : R Δ)          ⊢ t'' = applySubst (parallelS vs) t'+                                 ⊢ finalt = telePi tel t''       -}--      -- The type of the projection function should be-      --  {tel} -> (r : R Δ) -> t-      -- where Δ = Γ, tel is the current context-      let finalt   = telePi (replaceEmptyName "r" tel) t+      let t'       = raiseFrom (size ftel1) 1 t+          t''      = applySubst (parallelS vs) t'+          finalt   = telePi (replaceEmptyName "r" tel) t''           projname = qualify m $ qnameName x           projcall o = Var 0 [Proj o projname]           rel      = getRelevance ai           -- the recursive call           recurse  = checkProjs (abstract ftel1 $ ExtendTel dom                                  $ Abs (nameToArgName $ qnameName projname) EmptyTel)-                                (ftel2 `absApp` projcall ProjSystem) fs+                                (absBody ftel2) (projcall ProjSystem : vs) fs        reportSDoc "tc.rec.proj" 25 $ nest 2 $ "finalt=" <+> do         inTopContext $ prettyTCM finalt@@ -631,19 +667,18 @@                                     , conPFallThrough = False                                     , conPType   = Just $ argFromDom $ fmap snd rt                                     , conPLazy   = True }-            conp   = defaultArg $ ConP con cpi $-                     [ Arg ai' $ unnamed $ varP ("x" :: String)-                     | Dom{domInfo = ai'} <- telToList ftel-                     ]+            conp   = defaultNamedArg $ ConP con cpi $ teleNamedArgs ftel             body   = Just $ bodyMod $ var (size ftel2)             cltel  = ptel `abstract` ftel+            cltype = Just $ Arg ai $ raise (1 + size ftel2) t             clause = Clause { clauseLHSRange  = getRange info                             , clauseFullRange = getRange info                             , clauseTel       = killRange cltel-                            , namedClausePats = [Named Nothing <$> numberPatVars __IMPOSSIBLE__ (idP $ size ftel) conp]+                            , namedClausePats = [conp]                             , clauseBody      = body-                            , clauseType      = Just $ Arg ai t+                            , clauseType      = cltype                             , clauseCatchall  = False+                            , clauseExact       = Just True                             , clauseRecursive   = Just False                             , clauseUnreachable = Just False                             , clauseEllipsis  = NoEllipsis@@ -660,14 +695,9 @@               , projLams     = ProjLams $ map (argFromDom . fmap fst) telList               } -        reportSDoc "tc.rec.proj" 80 $ sep-          [ "adding projection"-          , nest 2 $ prettyTCM projname <+> text (show clause)-          ]         reportSDoc "tc.rec.proj" 70 $ sep           [ "adding projection"-          , nest 2 $ prettyTCM projname <+> text (show (clausePats clause)) <+> "=" <+>-                       inTopContext (addContext ftel (maybe "_|_" prettyTCM (clauseBody clause)))+          , nest 2 $ prettyTCM projname <+> pretty clause           ]         reportSDoc "tc.rec.proj" 10 $ sep           [ "adding projection"@@ -685,7 +715,7 @@               , nest 2 $ text (show cc)               ] -        escapeContext __IMPOSSIBLE__ (size tel) $ do+        escapeContext impossible (size tel) $ do           addConstant projname $             (defaultDefn ai projname (killRange finalt)               emptyFunction@@ -709,6 +739,6 @@         recurse      -- Case: definition.-    checkProjs ftel1 ftel2 (d : fs) = do+    checkProjs ftel1 ftel2 vs (d : fs) = do       checkDecl d-      checkProjs ftel1 ftel2 fs+      checkProjs ftel1 ftel2 vs fs

src/full/Agda/TypeChecking/Rules/Term.hs view

@@ -4,17 +4,19 @@  import Prelude hiding ( null ) +import Control.Monad.Except import Control.Monad.Reader  import Data.Maybe import Data.Either (partitionEithers, lefts)-import Data.Monoid (mappend) import qualified Data.List as List import qualified Data.Map as Map+import qualified Data.Set as Set  import Agda.Interaction.Options import Agda.Interaction.Highlighting.Generate (disambiguateRecordFields) +import Agda.Syntax.Abstract (Binder) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views as A import qualified Agda.Syntax.Info as A@@ -30,7 +32,6 @@                               , emptyScopeInfo                               , exportedNamesInScope) import Agda.Syntax.Scope.Monad (getNamedScope)-import Agda.Syntax.Translation.InternalToAbstract (reify)  import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Constraints@@ -43,9 +44,9 @@ import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.IApplyConfluence import Agda.TypeChecking.Level+import Agda.TypeChecking.Lock (requireGuarded) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Patterns.Abstract import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Pretty@@ -68,16 +69,17 @@ import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkSectionApplication) import {-# SOURCE #-} Agda.TypeChecking.Rules.Application -import Agda.Utils.Except-  (MonadError(catchError, throwError)) 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.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty ( prettyShow ) import qualified Agda.Utils.Pretty as P+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple @@ -108,37 +110,65 @@     , nest 2 $ "returns" <?> prettyTCM a     ]) $ do   let fallback = isType' CmpEq e =<< do workOnTypes $ newSortMeta+  SortKit{..} <- sortKit   case unScope e of     A.Fun i (Arg info t) b -> do-      a <- setArgInfo info . defaultDom <$> isType_ t+      a <- setArgInfo info . defaultDom <$> checkPiDomain (info :| []) t       b <- isType_ b       s <- inferFunSort (getSort a) (getSort b)       let t' = El s $ Pi a $ NoAbs underscore b-      noFunctionsIntoSize b t'+      --noFunctionsIntoSize t'       return t'-    A.Pi _ tel e | null tel -> isType_ e     A.Pi _ tel e -> do-      (t0, t') <- checkPiTelescope tel $ \ tel -> do+      (t0, t') <- checkPiTelescope (List1.toList tel) $ \ tel -> do         t0  <- instantiateFull =<< isType_ e         tel <- instantiateFull tel         return (t0, telePi tel t0)       checkTelePiSort t'-      noFunctionsIntoSize t0 t'+      --noFunctionsIntoSize t'       return t' +    A.Generalized s e -> do+      (_, t') <- generalizeType s $ isType_ e+      --noFunctionsIntoSize t'+      return t'+     -- Setᵢ-    A.Set _ n -> do-      return $ sort (mkType n)+    A.Def' x suffix | x == nameOfSet -> case suffix of+      NoSuffix -> return $ sort (mkType 0)+      Suffix i -> return $ sort (mkType i)      -- Propᵢ-    A.Prop _ n -> do+    A.Def' x suffix | x == nameOfProp -> do       unlessM isPropEnabled $ typeError NeedOptionProp-      return $ sort (mkProp n)+      case suffix of+        NoSuffix -> return $ sort (mkProp 0)+        Suffix i -> return $ sort (mkProp i) +    -- Setᵢ+    A.Def' x suffix | x == nameOfSSet -> do+      unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel+      case suffix of+        NoSuffix -> return $ sort (mkSSet 0)+        Suffix i -> return $ sort (mkSSet i)++    -- Setωᵢ+    A.Def' x suffix | x == nameOfSetOmega IsFibrant -> case suffix of+      NoSuffix -> return $ sort (Inf IsFibrant 0)+      Suffix i -> return $ sort (Inf IsFibrant i)++    -- SSetωᵢ+    A.Def' x suffix | x == nameOfSetOmega IsStrict -> do+      unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel+      case suffix of+        NoSuffix -> return $ sort (Inf IsStrict 0)+        Suffix i -> return $ sort (Inf IsStrict i)+     -- Set ℓ     A.App i s arg       | visible arg,-        A.Set _ 0 <- unScope s -> do+        A.Def x <- unScope s,+        x == nameOfSet -> do       unlessM hasUniversePolymorphism $ genericError         "Use --universe-polymorphism to enable level arguments to Set"       -- allow NonStrict variables when checking level@@ -149,13 +179,25 @@     -- Prop ℓ     A.App i s arg       | visible arg,-        A.Prop _ 0 <- unScope s -> do+        A.Def x <- unScope s,+        x == nameOfProp -> do       unlessM isPropEnabled $ typeError NeedOptionProp       unlessM hasUniversePolymorphism $ genericError         "Use --universe-polymorphism to enable level arguments to Prop"       applyRelevanceToContext NonStrict $         sort . Prop <$> checkLevel arg +    -- SSet ℓ+    A.App i s arg+      | visible arg,+        A.Def x <- unScope s,+        x == nameOfSSet -> do+      unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel+      unlessM hasUniversePolymorphism $ genericError+        "Use --universe-polymorphism to enable level arguments to SSet"+      applyRelevanceToContext NonStrict $+        sort . SSet <$> checkLevel arg+     -- Issue #707: Check an existing interaction point     A.QuestionMark minfo ii -> caseMaybeM (lookupInteractionMeta ii) fallback $ \ x -> do       -- -- | Just x <- A.metaNumber minfo -> do@@ -201,6 +243,9 @@ --   we are in the context of @tBlame@ in order to print it correctly. --   Not being in context of @t@ should not matter, as we are only --   checking whether its sort reduces to 'SizeUniv'.+--+--   Currently UNUSED since SizeUniv is turned off (as of 2016).+{- noFunctionsIntoSize :: Type -> Type -> TCM () noFunctionsIntoSize t tBlame = do   reportSDoc "tc.fun" 20 $ do@@ -216,12 +261,13 @@     -- We have constructed a function type in SizeUniv     -- which is illegal to prevent issue 1428.     typeError $ FunctionTypeInSizeUniv $ unEl tBlame+-}  -- | Check that an expression is a type which is equal to a given type. isTypeEqualTo :: A.Expr -> Type -> TCM Type isTypeEqualTo e0 t = scopedExpr e0 >>= \case   A.ScopedExpr{} -> __IMPOSSIBLE__-  A.Underscore i | A.metaNumber i == Nothing -> return t+  A.Underscore i | isNothing (A.metaNumber i) -> return t   e -> workOnTypes $ do     t' <- isType e (getSort t)     t' <$ leqType t t'@@ -267,6 +313,40 @@     checkTelescope' lamOrPi tel  $ \tel2 ->         ret $ abstract tel1 tel2 +-- | 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+    let (c :| cs) = fmap (getCohesion . getModality) xs+    unless (all (c ==) cs) $ __IMPOSSIBLE__++    let (q :| qs) = fmap (getQuantity . getModality) xs+    unless (all (q ==) qs) $ __IMPOSSIBLE__++    t <- applyQuantityToContext q $+         applyCohesionToContext c $+         modEnv lamOrPi $ isType_ e+    -- Andrea TODO: also make sure that LockUniv implies IsLock+    when (any (\ x -> getLock x == IsLock) xs) $ do+        requireGuarded "which is needed for @tick/@lock attributes."+         -- Solves issue #5033+        unlessM (isJust <$> getName' builtinLockUniv) $ do+          genericDocError $ "Missing binding for primLockUniv primitive."++        equalSort (getSort t) LockUniv++    return 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++checkPiDomain :: (LensLock a, LensModality a) => List1 a -> A.Expr -> TCM Type+checkPiDomain = checkDomain PiNotLam+ -- | Check a typed binding and extends the context with the bound variables. --   The telescope passed to the continuation is valid in the original context. --@@ -275,7 +355,7 @@  checkTypedBindings :: LamOrPi -> A.TypedBinding -> (Telescope -> TCM a) -> TCM a checkTypedBindings lamOrPi (A.TBind r tac xps e) ret = do-    let xs = map (updateNamedArg $ A.unBind . A.binderName) xps+    let xs = fmap (updateNamedArg $ A.unBind . A.binderName) xps     tac <- traverse (checkTacticAttribute lamOrPi) tac     whenJust tac $ \ t -> reportSDoc "tc.term.tactic" 30 $ "Checked tactic attribute:" <?> prettyTCM t     -- Andreas, 2011-04-26 irrelevant function arguments may appear@@ -283,15 +363,11 @@     -- 2011-10-04 if flag --experimental-irrelevance is set     experimental <- optExperimentalIrrelevance <$> pragmaOptions -    let cs = map getCohesion xps-        c = headWithDefault __IMPOSSIBLE__ cs-    unless (all (c ==) cs) $ __IMPOSSIBLE__--    t <- applyCohesionToContext c $ modEnv lamOrPi $ isType_ e+    t <- checkDomain lamOrPi xps e      -- Jesper, 2019-02-12, Issue #3534: warn if the type of an     -- instance argument does not have the right shape-    unlessNull (filter isInstance xps) $ \ixs -> do+    List1.unlessNull (List1.filter isInstance xps) $ \ ixs -> do       (tel, target) <- getOutputTypeName t       case target of         OutputTypeName{} -> return ()@@ -302,8 +378,8 @@      let setTac tac EmptyTel            = EmptyTel         setTac tac (ExtendTel dom tel) = ExtendTel dom{ domTactic = tac } $ setTac (raise 1 tac) <$> tel-        xs' = map (modMod lamOrPi experimental) xs-    let tel = setTac tac $ namedBindsToTel xs t+        xs' = fmap (modMod lamOrPi experimental) xs+    let tel = setTac tac $ namedBindsToTel1 xs t      addContext (xs', t) $ addTypedPatterns xps (ret tel) @@ -315,25 +391,22 @@         modEnv LamNotPi = workOnTypes         modEnv _        = id         modMod PiNotLam xp = (if xp then mapRelevance irrToNonStrict else id)-                           . (setQuantity topQuantity)         modMod _        _  = id+ checkTypedBindings lamOrPi (A.TLet _ lbs) ret = do     checkLetBindings lbs (ret EmptyTel)  -- | After a typed binding has been checked, add the patterns it binds-addTypedPatterns :: [NamedArg A.Binder] -> TCM a -> TCM a+addTypedPatterns :: List1 (NamedArg A.Binder) -> TCM a -> TCM a addTypedPatterns xps ret = do-  let ps  = mapMaybe (A.extractPattern . namedArg) xps-  let lbs = fmap letBinding ps+  let ps  = List1.mapMaybe (A.extractPattern . namedArg) xps+  let lbs = map letBinding ps   checkLetBindings lbs ret-   where-     letBinding :: (A.Pattern, A.BindName) -> A.LetBinding     letBinding (p, n) = A.LetPatBind (A.LetRange r) p (A.Var $ A.unBind n)       where r = fuseRange p n - -- | Check a tactic attribute. Should have type Term → TC ⊤. checkTacticAttribute :: LamOrPi -> A.Expr -> TCM Term checkTacticAttribute LamNotPi e = genericDocError =<< "The @tactic attribute is not allowed here"@@ -347,11 +420,11 @@   if isPathType pv then work else fallback  checkPath :: A.TypedBinding -> A.Expr -> Type -> TCM Term-checkPath b@(A.TBind _ _ [x'] typ) body ty = do+checkPath b@(A.TBind _ _ (x':|[]) typ) body ty = do     let x    = updateNamedArg (A.unBind . A.binderName) x'         info = getArgInfo x     PathType s path level typ lhs rhs <- pathView ty-    interval <- elInf primInterval+    interval <- primIntervalType     v <- addContext ([x], interval) $            checkExpr body (El (raise 1 s) (raise 1 (unArg typ) `apply` [argN $ var 0]))     iZero <- primIZero@@ -374,10 +447,32 @@ checkLambda :: Comparison -> A.TypedBinding -> A.Expr -> Type -> TCM Term checkLambda cmp (A.TLet _ lbs) body target =   checkLetBindings lbs (checkExpr body target)-checkLambda cmp b@(A.TBind _ _ xps typ) body target = do+checkLambda cmp b@(A.TBind r tac xps0 typ) body target = do+  reportSDoc "tc.term.lambda" 30 $ vcat+    [ "checkLambda before insertion xs =" <+> prettyA xps0+    ]+  -- Andreas, 2020-03-25, issue #4481: since we have named lambdas now,+  -- we need to insert skipped hidden arguments.+  xps <- insertImplicitBindersT1 xps0 target+  checkLambda' cmp (A.TBind r tac xps typ) xps typ body target++checkLambda'+  :: Comparison          -- ^ @cmp@+  -> A.TypedBinding      -- ^ @TBind _ _ xps typ@+  -> List1 (NamedArg Binder)   -- ^ @xps@+  -> A.Expr              -- ^ @typ@+  -> A.Expr              -- ^ @body@+  -> Type                -- ^ @target@+  -> TCM Term+checkLambda' cmp b xps typ body target = do+  reportSDoc "tc.term.lambda" 30 $ vcat+    [ "checkLambda xs =" <+> prettyA xps+    , "possiblePath   =" <+> prettyTCM possiblePath+    , "numbinds       =" <+> prettyTCM numbinds+    , "typ            =" <+> prettyA   (unScope typ)+    ]   reportSDoc "tc.term.lambda" 60 $ vcat-    [ "checkLambda xs = " <+> prettyA xps-    , "possiblePath = " <+> text (show (possiblePath, numbinds, unScope typ, info))+    [ "info           =" <+> (text . show) info     ]   TelV tel btyp <- telViewUpTo numbinds target   if size tel < numbinds || numbinds /= 1@@ -386,12 +481,12 @@    where -    xs = map (updateNamedArg (A.unBind . A.binderName)) xps+    xs = fmap (updateNamedArg (A.unBind . A.binderName)) xps     numbinds = length xps-    isUnderscore e = case e of { A.Underscore{} -> True; _ -> False }+    isUnderscore = \case { A.Underscore{} -> True; _ -> False }     possiblePath = numbinds == 1 && isUnderscore (unScope typ)                    && isRelevant info && visible info-    info = getArgInfo (headWithDefault __IMPOSSIBLE__ xs)+    info = getArgInfo $ List1.head xs      trySeeingIfPath = do       cubical <- optCubical <$> pragmaOptions@@ -402,7 +497,7 @@           then checkPath b body t           else genericError "Option --cubical needed to build a path with a lambda abstraction" -    postpone m tgt = postponeTypeCheckingProblem_ $+    postpone blocker tgt = flip postponeTypeCheckingProblem blocker $       CheckExpr cmp (A.Lam A.exprNoRange (A.DomainFull b) body) tgt      dontUseTargetType = do@@ -411,8 +506,8 @@        -- First check that argsT is a valid type       argsT <- workOnTypes $ isType_ typ-      let tel = namedBindsToTel xs argsT-      reportSDoc "tc.term.lambda" 60 $ "dontUseTargetType tel =" <+> pretty tel+      let tel = namedBindsToTel1 xs argsT+      reportSDoc "tc.term.lambda" 30 $ "dontUseTargetType tel =" <+> pretty tel        -- Andreas, 2015-05-28 Issue 1523       -- If argsT is a SizeLt, it must be non-empty to avoid non-termination.@@ -429,7 +524,7 @@             t1 <- addContext (xs, argsT) $ workOnTypes newTypeMeta_             let e    = A.Lam A.exprNoRange (A.DomainFull b) body                 tgt' = telePi tel t1-            w <- postponeTypeCheckingProblem (CheckExpr cmp e tgt') $ isInstantiatedMeta x+            w <- postponeTypeCheckingProblem (CheckExpr cmp e tgt') x             return (tgt' , w)        -- Now check body : ?t₁@@ -451,10 +546,14 @@      useTargetType tel@(ExtendTel dom (Abs y EmptyTel)) btyp = do         verboseS "tc.term.lambda" 5 $ tick "lambda-with-target-type"-        reportSLn "tc.term.lambda" 60 $ "useTargetType y  = " ++ y+        reportSLn "tc.term.lambda" 30 $ "useTargetType y  = " ++ y -        let [x] = xs+        let (x :| []) = xs         unless (sameHiding dom info) $ typeError $ WrongHidingInLambda target+        when (isJust $ getNameOf x) $+          -- Andreas, 2020-03-25, issue #4481: check for correct name+          unless (namedSame dom x) $+            setCurrentRange x $ typeError $ WrongHidingInLHS         -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given         info <- lambdaModalityCheck dom info         -- Andreas, 2015-05-28 Issue 1523@@ -477,8 +576,8 @@ -- | 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 :: LensModality dom => dom -> ArgInfo -> TCM ArgInfo-lambdaModalityCheck dom = lambdaCohesionCheck m <=< lambdaQuantityCheck m <=< lambdaIrrelevanceCheck m+lambdaModalityCheck :: (LensAnnotation dom, LensModality dom) => dom -> ArgInfo -> TCM ArgInfo+lambdaModalityCheck dom = lambdaAnnotationCheck (getAnnotation dom) <=< lambdaCohesionCheck m <=< lambdaQuantityCheck m <=< lambdaIrrelevanceCheck m   where m = getModality dom  -- | Check that irrelevance info in lambda is compatible with irrelevance@@ -515,10 +614,22 @@   | otherwise = do       let qPi  = getQuantity dom  -- quantity of function type       let qLam = getQuantity info -- quantity of lambda-      unless (qPi `moreQuantity` qLam) $ do+      unless (qPi `sameQuantity` qLam) $ do         typeError WrongQuantityInLambda       return info +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+    -- Case: explicit user annotation is taken seriously+  | otherwise = do+      let aPi  = getAnnotation dom  -- annotation of function type+      let aLam = getAnnotation info -- annotation of lambda+      unless (aPi == aLam) $ do+        typeError $ GenericError $ "Wrong annotation in lambda"+      return info+ -- | Check that cohesion info in lambda is compatible with cohesion --   coming from the function type. --   If lambda has no user-given cohesion, copy that of function type.@@ -536,16 +647,17 @@         typeError WrongCohesionInLambda       return info +-- Andreas, issue #630: take name from function type if lambda name is "_". lambdaAddContext :: Name -> ArgName -> Dom Type -> TCM a -> TCM a lambdaAddContext x y dom   | isNoName x = addContext (y, dom)                 -- Note: String instance   | otherwise  = addContext (x, dom)                 -- Name instance of addContext  -- | Checking a lambda whose domain type has already been checked.-checkPostponedLambda :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term-checkPostponedLambda cmp args@(Arg _    ([]    , _ )) body target = do-  checkExpr' cmp body target-checkPostponedLambda cmp args@(Arg info (WithHiding h x : xs, mt)) body target = do+checkPostponedLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> A.Expr -> Type -> TCM Term+-- checkPostponedLambda cmp args@(Arg _    ([]    , _ )) body target = do+--   checkExpr' cmp body target+checkPostponedLambda cmp args@(Arg info (WithHiding h x :| xs, mt)) body target = do   let postpone _ t = postponeTypeCheckingProblem_ $ CheckLambda cmp args body t       lamHiding = mappend h $ getHiding info   insertHiddenLambdas lamHiding target postpone $ \ t@(El _ (Pi dom b)) -> do@@ -565,18 +677,24 @@     let dom' = setRelevance (getRelevance info') . setHiding lamHiding $           maybe dom (dom $>) mt     v <- lambdaAddContext x (absName b) dom'  $-      checkPostponedLambda cmp (Arg info (xs, mt)) body $ absBody b+      checkPostponedLambda0 cmp (Arg info (xs, mt)) body $ absBody b     let v' = Lam info' $ Abs (nameToArgName x) v     maybe (return v') (blockTermOnProblem t v') mpid +checkPostponedLambda0 :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term+checkPostponedLambda0 cmp (Arg _    ([]    , _ )) body target =+  checkExpr' cmp body target+checkPostponedLambda0 cmp (Arg info (x : xs, mt)) body target =+  checkPostponedLambda cmp (Arg info (x :| xs, mt)) body target + -- | Insert hidden lambda until the hiding info of the domain type --   matches the expected hiding info. --   Throws 'WrongHidingInLambda' insertHiddenLambdas   :: Hiding                       -- ^ Expected hiding.   -> Type                         -- ^ Expected to be a function type.-  -> (MetaId -> Type -> TCM Term) -- ^ Continuation on blocked type.+  -> (Blocker -> Type -> TCM Term) -- ^ Continuation on blocked type.   -> (Type -> TCM Term)           -- ^ Continuation when expected hiding found.                                   --   The continuation may assume that the @Type@                                   --   is of the form @(El _ (Pi _ _))@.@@ -611,13 +729,10 @@       -- See test/Succeed/Issue3176.agda for an absurd lambda       -- created in types.   t <- instantiateFull t-  ifBlocked t (\ m t' -> postponeTypeCheckingProblem_ $ CheckExpr cmp e t') $ \ _ t' -> do+  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'-        | not (noMetas a) ->-            postponeTypeCheckingProblem (CheckExpr cmp e t') $-              noMetas <$> instantiateFull a         | otherwise -> blockTerm t' $ do           ensureEmptyType (getRange i) a           -- Add helper function@@ -643,32 +758,37 @@                     , namedClausePats = [Arg info' $ Named (Just $ WithOrigin Inserted $ unranged $ absName b) $ absurdP 0]                     , clauseBody      = Nothing                     , clauseType      = Just $ setModality mod $ defaultArg $ absBody b-                    , clauseCatchall  = False+                    , clauseCatchall    = True      -- absurd clauses are safe as catch-alls+                    , clauseExact       = Just False                     , clauseRecursive   = Just False                     , clauseUnreachable = Just True -- absurd clauses are unreachable                     , clauseEllipsis  = NoEllipsis                     }                   ]-              , funCompiled       = Just Fail+              , funCompiled       = Just $ Fail [Arg info' "()"]               , funSplitTree      = Just $ SplittingDone 0               , funMutual         = Just []               , funTerminates     = Just True+              , funExtLam         = Just $ ExtLamInfo top True empty               }           -- Andreas 2012-01-30: since aux is lifted to toplevel           -- it needs to be applied to the current telescope (issue 557)-          tel <- getContextTelescope-          return $ Def aux $ map Apply $ teleArgs tel+          Def aux . map Apply . teleArgs <$> getContextTelescope       _ -> typeError $ ShouldBePi t' --- | @checkExtendedLambda i di qname cs e t@ check pattern matching lambda.--- Precondition: @e = ExtendedLam i di qname cs@-checkExtendedLambda :: Comparison -> A.ExprInfo -> A.DefInfo -> QName -> [A.Clause] ->-                       A.Expr -> Type -> TCM Term-checkExtendedLambda cmp i di qname cs e t = localTC (set eQuantity topQuantity) $ do-      -- Andreas, 2019-10-01: check extended lambdas in non-erased mode.-      -- Otherwise, they are not usable in meta-solutions in the term world.-      -- See test/Succeed/Issue{3581}.agda for an extended lambda-      -- created in a type.+-- | @checkExtendedLambda i di erased qname cs e t@ check pattern matching lambda.+-- Precondition: @e = ExtendedLam i di erased qname cs@+checkExtendedLambda ::+  Comparison -> A.ExprInfo -> A.DefInfo -> Erased -> QName ->+  List1 A.Clause -> A.Expr -> Type -> TCM Term+checkExtendedLambda cmp i di erased qname cs e t = do+  mod <- asksTC getModality+  if isErased erased && not (hasQuantity0 mod) then+    genericError $ unwords+      [ "Erased pattern-matching lambdas may only be used in erased"+      , "contexts"+      ]+   else localTC (set eQuantity $ asQuantity erased) $ do    -- Andreas, 2016-06-16 issue #2045    -- Try to get rid of unsolved size metas before we    -- fix the type of the extended lambda auxiliary function@@ -680,26 +800,32 @@      mod <- asksTC getModality      let info = setModality mod defaultArgInfo -     reportSDoc "tc.term.exlam" 20 $-       (text (show $ A.defAbstract di) <+>-       "extended lambda's implementation \"") <> prettyTCM qname <>-       "\" has type: " $$ prettyTCM t -- <+> " where clauses: " <+> text (show cs)+     reportSDoc "tc.term.exlam" 20 $ vcat+       [ hsep+         [ text $ show $ A.defAbstract di+         , "extended lambda's implementation"+         , doubleQuotes $ prettyTCM qname+         , "has type:"+         ]+       , prettyTCM t -- <+> " where clauses: " <+> text (show cs)+       ]      args     <- getContextArgs       -- Andreas, Ulf, 2016-02-02: We want to postpone type checking an extended lambda      -- in case the lhs checker failed due to insufficient type info for the patterns.      -- Issues 480, 1159, 1811.-     (abstract (A.defAbstract di) $ do+     abstract (A.defAbstract di) $ do        -- Andreas, 2013-12-28: add extendedlambda as @Function@, not as @Axiom@;        -- otherwise, @addClause@ in @checkFunDef'@ fails (see issue 1009).        addConstant qname =<< do          useTerPragma $            (defaultDefn info qname t emptyFunction) { defMutual = j }-       checkFunDef' t info NotDelayed (Just $ ExtLamInfo lamMod empty) Nothing di qname cs+       checkFunDef' t info NotDelayed (Just $ ExtLamInfo lamMod False empty) Nothing di qname $+         List1.toList cs        whenNothingM (asksTC envMutualBlock) $          -- 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@@ -709,7 +835,7 @@ -- --   * If successful, that's it, we are done. -----   * If @IlltypedPattern p a@, @NotADatatype a@ or @CannotEliminateWithPattern p a@+--   * If @NotADatatype a@ or @CannotEliminateWithPattern p a@ --     is thrown and type @a@ is blocked on some meta @x@, --     reset any changes to the state and pass (the error and) @x@ to the handler. --@@ -721,7 +847,7 @@ --   Note that the returned meta might only exists in the state where the error was --   thrown, thus, be an invalid 'MetaId' in the current state. ---catchIlltypedPatternBlockedOnMeta :: TCM a -> ((TCErr, MetaId) -> TCM a) -> TCM a+catchIlltypedPatternBlockedOnMeta :: TCM a -> ((TCErr, Blocker) -> TCM a) -> TCM a catchIlltypedPatternBlockedOnMeta m handle = do    -- Andreas, 2016-07-13, issue 2028.@@ -730,41 +856,25 @@    m `catchError` \ err -> do -    let reraise = throwError err+    let reraise :: MonadError TCErr m => m a+        reraise = throwError err -    -- Get the blocking meta responsible for the type error.-    -- If we do not find such a meta or the error should not be handled,+    -- 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.-    x <- maybe reraise return =<< do-      case err of-        TypeError s cl -> localTCState $ do-          putTC s-          enterClosure cl $ \case-            IlltypedPattern p a -> isBlocked a--            SplitError (UnificationStuck c tel us vs _) -> do-              -- Andreas, 2018-11-23, re issue #3403-              -- The following computation of meta-variables and picking-              -- of the first one, seems a bit brittle.-              -- I do not understand why there is a single @reduce@ here-              -- (seems to archieve a bit along @normalize@, but how much??).-              problem <- reduce =<< instantiateFull (flattenTel tel, us, vs)-              -- over-approximating the set of metas actually blocking unification-              return $ firstMeta problem--            SplitError (NotADatatype aClosure) ->-              enterClosure aClosure $ \ a -> isBlocked a--            -- Andrea: TODO look for blocking meta in tClosure and its Sort.-            -- SplitError (CannotCreateMissingClause _ _ _ tClosure) ->--            CannotEliminateWithPattern p a -> isBlocked a--            _ -> return Nothing-        _ -> return Nothing+    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+        -- Andrea: TODO look for blocking meta in tClosure and its Sort.+        -- SplitError (CannotCreateMissingClause _ _ _ tClosure) ->+        _                                             -> Nothing+      _ -> Nothing      reportSDoc "tc.postpone" 20 $ vcat $-      [ "checking definition blocked on meta: " <+> prettyTCM x ]+      [ "checking definition blocked on: " <+> prettyTCM blocker ]      -- Note that we messed up the state a bit.  We might want to unroll these state changes.     -- However, they are mostly harmless:@@ -774,26 +884,29 @@     -- Thus, reset the state!     putTC st -    -- The meta might not be known in the reset state, as it could have been created-    -- somewhere on the way to the type error.-    lookupMeta' x >>= \case-      -- Case: we do not know the meta, so we reraise.-      Nothing -> reraise+    -- There might be metas in the blocker not known in the reset state, as they could have been+    -- created somewhere on the way to the type error.+    blocker <- (`onBlockingMetasM` blocker) $ \ x ->+                lookupMeta' x >>= \ case+      -- Case: we do not know the meta, so cannot unblock.+      Nothing -> return neverUnblock       -- Case: we know the meta here.+      -- Just m | InstV{} <- mvInstantiation m -> __IMPOSSIBLE__  -- It cannot be instantiated yet.       -- Andreas, 2018-11-23: I do not understand why @InstV@ is necessarily impossible.       -- The reasoning is probably that the state @st@ is more advanced that @s@       -- in which @x@ was blocking, thus metas in @st@ should be more instantiated than-      -- in @s@.  But issue #3403 presents a counterexample, so let's play save and reraise-      -- Just m | InstV{} <- mvInstantiation m -> __IMPOSSIBLE__  -- It cannot be instantiated yet.-      Just m | InstV{} <- mvInstantiation m -> reraise-      -- Case: the meta is frozen (and not an interaction meta).-      -- Postponing doesn't make sense, so we reraise.-      Just m | Frozen  <- mvFrozen m -> isInteractionMeta x >>= \case-        Nothing -> reraise-      -- Remaining cases: the meta is known and can still be instantiated.-        Just{}  -> handle (err, x)-      Just{} -> handle (err, x)+      -- in @s@.  But issue #3403 presents a counterexample, so let's play save and reraise.+      -- Ulf, 2020-08-13: But treat this case as not blocked and reraise on both always and never.+      -- Ulf, 2020-08-13: Previously we returned neverUnblock for frozen metas here, but this is in+      -- fact not very helpful. Yes there is no hope of solving the problem, but throwing a hard+      -- error means we rob the user of the tools needed to figure out why the meta has not been+      -- solved. Better to leave the constraint.+      Just m | InstV{} <- mvInstantiation m -> return alwaysUnblock+             | otherwise -> return $ unblockOnMeta x +    -- 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)+ --------------------------------------------------------------------------- -- * Records ---------------------------------------------------------------------------@@ -828,9 +941,8 @@       [(_, fa)] -> return (Just fa)       mfas      -> typeError . GenericDocError =<< do         vcat $-          [ "Ambiguity: the field" <+> prettyTCM f-            <+> "appears in the following modules: " ]-          ++ map (prettyTCM . fst) mfas+          "Ambiguity: the field" <+> prettyTCM f+            <+> "appears in the following modules: " : map (prettyTCM . fst) mfas   return (fs ++ catMaybes fs')  -- | @checkRecordExpression fs e t@ checks record construction against type @t@.@@ -890,22 +1002,23 @@       -- In @es@ omitted explicit fields are replaced by underscores.       -- Omitted implicit or instance fields       -- are still left out and inserted later by checkArguments_.-      es <- insertMissingFields r meta fs cxs+      es <- insertMissingFieldsWarn r meta fs cxs -      args <- checkArguments_ ExpandLast re es (recTel def `apply` vs) >>= \case+      args <- checkArguments_ cmp ExpandLast re es (recTel def `apply` vs) >>= \case         (elims, remainingTel) | null remainingTel                               , Just args <- allApplyElims elims -> return args         _ -> __IMPOSSIBLE__       -- Don't need to block here!       reportSDoc "tc.term.rec" 20 $ text $ "finished record expression"       return $ Con con ConORec (map Apply args)-    _         -> typeError $ ShouldBeRecordType t+    _ -> 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.         [] -> case fields of@@ -914,8 +1027,12 @@           _   -> genericError $ "There is no known record with the fields " ++ unwords (map prettyShow fields)           -- If there's only one record with the appropriate fields, go with that.         [r] -> do-          def <- getConstInfo r+          -- #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@@ -929,7 +1046,7 @@                       , text $ "  Raw                   =  " ++ show v                       ]                     __IMPOSSIBLE__-          let inferred = El s $ Def r $ map Apply vs+          let inferred = El s $ Def r $ map Apply (ps ++ vs)           v <- checkExpr e inferred           coerce cmp v inferred t           -- Andreas 2012-04-21: OLD CODE, WRONG DIRECTION, I GUESS:@@ -953,42 +1070,51 @@   -> A.Expr       -- ^ @recexpr@   -> A.Assigns    -- ^ @fs@   -> A.Expr       -- ^ @e = RecUpdate ei recexpr fs@-  -> Type         -- ^ Reduced.+  -> Type         -- ^ Need not be reduced.   -> TCM Term-checkRecordUpdate cmp ei recexpr fs e t = do-  case unEl t of-    Def r vs  -> do-      v <- checkExpr' cmp recexpr t-      name <- freshNoName (getRange recexpr)-      addLetBinding defaultArgInfo name v t $ do-        projs <- map argFromDom . recFields <$> getRecordDef r+checkRecordUpdate cmp ei recexpr fs eupd t = do+  ifBlocked t (\ _ _ -> tryInfer) $ {-else-} \ _ t' -> do+    caseMaybeM (isRecordType t') should $ \ (r, _pars, defn) -> do+      -- Bind the record value (before update) to a fresh @name@.+      v <- checkExpr' cmp recexpr t'+      name <- freshNoName $ getRange recexpr+      addLetBinding defaultArgInfo name v t' $ do +        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) +        -- Desugar record update expression into record expression.+        let fs' = map (\ (FieldAssignment x e) -> (x, Just e)) fs         axs <- map argFromDom <$> getRecordFieldNames r-        let xs = map unArg axs-        es <- orderFields r (\ _ -> Nothing) axs $ map (\ (FieldAssignment x e) -> (x, Just e)) fs-        let es' = zipWith (replaceFields name ei) projs es-        checkExpr' cmp (A.Rec ei [ Left (FieldAssignment x e) | (x, Just e) <- zip xs es' ]) t--    MetaV _ _ -> do-      inferred <- inferExpr recexpr >>= reduce . snd-      case unEl inferred of-        MetaV _ _ -> postponeTypeCheckingProblem_ $ CheckExpr cmp e t-        _         -> do-          v <- checkExpr' cmp e inferred-          coerce cmp v inferred t-    _         -> typeError $ ShouldBeRecordType t+        es  <- orderFieldsWarn r (const Nothing) axs fs'+        let es'  = zipWith (replaceFields name ei) projs es+        let erec = A.Rec ei [ Left (FieldAssignment x e) | (Arg _ x, Just e) <- zip axs es' ]+        -- Call the type checker on the desugared syntax.+        checkExpr' cmp erec t   where     replaceFields :: Name -> A.ExprInfo -> Arg A.QName -> Maybe A.Expr -> Maybe A.Expr-    replaceFields n ei a@(Arg _ p) Nothing | visible a =-        Just $ A.App (A.defaultAppInfo $ getRange ei) (A.Def p) $ defaultNamedArg $ A.Var n-    replaceFields _ _  (Arg _ _) Nothing  = Nothing-    replaceFields _ _  _         (Just e) = Just $ e+    replaceFields name ei (Arg ai p) Nothing | visible ai = Just $+      -- omitted visible fields remain unchanged: @{ ...; p = p name; ...}@+      -- (hidden fields are supposed to be inferred)+      A.App+        (A.defaultAppInfo $ getRange ei)+        (A.Proj ProjSystem $ unambiguous p)+        (defaultNamedArg $ A.Var name)+    replaceFields _ _ _ me = me  -- other fields get the user-written updates +    tryInfer = do+      (_, trec) <- inferExpr recexpr+      ifBlocked trec (\ _ _ -> postpone) $ {-else-} \ _ _ -> do+        v <- checkExpr' cmp eupd trec+        coerce cmp v trec t++    postpone = postponeTypeCheckingProblem_ $ CheckExpr cmp eupd t+    should   = typeError $ ShouldBeRecordType t+ --------------------------------------------------------------------------- -- * Literal ---------------------------------------------------------------------------@@ -1040,11 +1166,11 @@      e <- scopedExpr e -    irrelevantIfProp <- isPropM t >>= \case-      True  -> do+    irrelevantIfProp <- (runBlocked $ isPropM t) >>= \case+      Right True  -> do         let mod = defaultModality { modRelevance = Irrelevant }         return $ fmap dontCare . applyModalityToContext mod-      False -> return id+      _ -> return id      irrelevantIfProp $ tryInsertHiddenLambda e tReduced $ case e of @@ -1056,47 +1182,9 @@          A.WithApp _ e es -> typeError $ NotImplemented "type checking of with application" -        -- check |- Set l : t  (requires universe polymorphism)-        A.App i s arg@(Arg ai l)-          | A.Set _ 0 <- unScope s, visible ai ->-          ifNotM hasUniversePolymorphism-              (genericError "Use --universe-polymorphism to enable level arguments to Set")-          $ {- else -} do-            -- allow NonStrict variables when checking level-            --   Set : (NonStrict) Level -> Set\omega-            n <- applyRelevanceToContext NonStrict $ checkLevel arg-            -- check that Set (l+1) <= t-            reportSDoc "tc.univ.poly" 10 $-              "checking Set " <+> prettyTCM n <+>-              "against" <+> prettyTCM t-            coerce cmp (Sort $ Type n) (sort $ Type $ levelSuc n) t--        -- check |- Prop l : t  (requires universe polymorphism)-        A.App i s arg@(Arg ai l)-          | A.Prop _ 0 <- unScope s, visible ai ->-          ifNotM hasUniversePolymorphism-              (genericError "Use --universe-polymorphism to enable level arguments to Prop")-          $ {- else -} do-            n <- applyRelevanceToContext NonStrict $ checkLevel arg-            reportSDoc "tc.univ.poly" 10 $-              "checking Prop " <+> prettyTCM n <+>-              "against" <+> prettyTCM t-            coerce cmp (Sort $ Prop n) (sort $ Type $ levelSuc n) t-         e0@(A.App i q (Arg ai e))           | A.Quote _ <- unScope q, visible ai -> do-          let quoted (A.Def x) = return x-              quoted (A.Macro x) = return x-              quoted (A.Proj o p) | Just x <- getUnambiguous p = return x-              quoted (A.Proj o p)  =-                genericError $ "quote: Ambigous name: " ++ prettyShow (unAmbQ p)-              quoted (A.Con c) | Just x <- getUnambiguous c = return x-              quoted (A.Con c)  =-                genericError $ "quote: Ambigous name: " ++ prettyShow (unAmbQ c)-              quoted (A.ScopedExpr _ e) = quoted e-              quoted _                  =-                genericError "quote: not a defined name"-          x <- quoted (namedThing e)+          x <- quotedName $ namedThing e           ty <- qNameType           coerce cmp (quoteName x) ty t @@ -1110,63 +1198,40 @@          A.AbsurdLam i h -> checkAbsurdLambda cmp i h e t -        A.ExtendedLam i di qname cs -> checkExtendedLambda cmp i di qname cs e t+        A.ExtendedLam i di erased qname cs ->+          checkExtendedLambda cmp i di erased qname cs e t          A.Lam i (A.DomainFull b) e -> checkLambda cmp b e t          A.Lam i (A.DomainFree _ x) e0           | isNothing (nameOf $ unArg x) && isNothing (A.binderPattern $ namedArg x) ->-              checkExpr' cmp (A.Lam i (domainFree (getArgInfo x) $ fmap A.unBind $ namedArg x) e0) t+              checkExpr' cmp (A.Lam i (domainFree (getArgInfo x) $ A.unBind <$> namedArg x) e0) t           | otherwise -> typeError $ NotImplemented "named arguments in lambdas" -        A.Lit lit    -> checkLiteral lit t+        A.Lit _ lit  -> checkLiteral lit t         A.Let i ds e -> checkLetBindings ds $ checkExpr' cmp e t-        A.Pi _ tel e | null tel -> checkExpr' cmp e t-        A.Pi _ tel e -> do-            (t0, t') <- checkPiTelescope tel $ \ tel -> do-                    t0  <- instantiateFull =<< isType_ e-                    tel <- instantiateFull tel-                    return (t0, telePi tel t0)-            checkTelePiSort t'-            noFunctionsIntoSize t0 t'+        e@A.Pi{} -> do+            t' <- isType_ e             let s = getSort t'                 v = unEl t'-            when (s == Inf) $ reportSDoc "tc.term.sort" 20 $-              vcat [ text ("reduced to omega:")-                   , nest 2 $ "t   =" <+> prettyTCM t'-                   , nest 2 $ "cxt =" <+> (prettyTCM =<< getContextTelescope)-                   ]             coerce cmp v (sort s) t          A.Generalized s e -> do             (_, t') <- generalizeType s $ isType_ e-            noFunctionsIntoSize t' t'+            --noFunctionsIntoSize t' t'             let s = getSort t'                 v = unEl t'-            when (s == Inf) $ reportSDoc "tc.term.sort" 20 $-              vcat [ text ("reduced to omega:")-                   , nest 2 $ "t   =" <+> prettyTCM t'-                   , nest 2 $ "cxt =" <+> (prettyTCM =<< getContextTelescope)-                   ]             coerce cmp v (sort s) t -        A.Fun _ (Arg info a) b -> do-            a' <- isType_ a-            let adom = defaultArgDom info a'-            b' <- isType_ b-            s  <- inferFunSort (getSort a') (getSort b')-            let v = Pi adom (NoAbs underscore b')-            noFunctionsIntoSize b' $ El s v+        e@A.Fun{} -> do+            t' <- isType_ e+            let s = getSort t'+                v = unEl t'             coerce cmp v (sort s) t-        A.Set _ n    -> do-          coerce cmp (Sort $ mkType n) (sort $ mkType $ n + 1) t-        A.Prop _ n   -> do-          unlessM isPropEnabled $ typeError NeedOptionProp-          coerce cmp (Sort $ mkProp n) (sort $ mkType $ n + 1) t          A.Rec _ fs  -> checkRecordExpression cmp fs e t -        A.RecUpdate ei recexpr fs -> checkRecordUpdate cmp ei recexpr fs e tReduced+        A.RecUpdate ei recexpr fs -> checkRecordUpdate cmp ei recexpr fs e t          A.DontCare e -> -- resurrect vars           ifM ((Irrelevant ==) <$> asksTC getRelevance)@@ -1186,15 +1251,15 @@         -- being sure it will be retried when a meta is solved         -- (which might be the blocking meta in which case we actually make progress).         reportSDoc "tc.term" 50 $ vcat $-          [ "checking pattern got stuck on meta: " <+> text (show x) ]-        postponeTypeCheckingProblem (CheckExpr cmp e t) $ isInstantiatedMeta x+          [ "checking pattern got stuck on meta: " <+> pretty x ]+        postponeTypeCheckingProblem (CheckExpr cmp e t) x    where-  -- | Call checkExpr with an hidden lambda inserted if appropriate,-  --   else fallback.+  -- Call checkExpr with an hidden lambda inserted if appropriate,+  -- else fallback.   tryInsertHiddenLambda     :: A.Expr-    -> Type      -- ^ Reduced.+    -> Type      -- Reduced.     -> TCM Term     -> TCM Term   tryInsertHiddenLambda e tReduced fallback@@ -1234,12 +1299,12 @@       reportSLn "tc.term.expr.impl" 15 $ "Inserting implicit lambda"       checkExpr' cmp (A.Lam (A.ExprRange re) (domainFree info $ A.mkBinder x) e) tReduced -    hiddenLambdaOrHole h e = case e of-      A.AbsurdLam _ h'        -> sameHiding h h'-      A.ExtendedLam _ _ _ cls -> any hiddenLHS cls-      A.Lam _ bind _          -> sameHiding h bind-      A.QuestionMark{}        -> True-      _                       -> False+    hiddenLambdaOrHole h = \case+      A.AbsurdLam _ h'          -> sameHiding h h'+      A.ExtendedLam _ _ _ _ cls -> any hiddenLHS cls+      A.Lam _ bind _            -> sameHiding h bind+      A.QuestionMark{}          -> True+      _                         -> False      hiddenLHS (A.Clause (A.LHS _ (A.LHSHead _ (a : _))) _ _ _ _) = notVisible a     hiddenLHS _ = False@@ -1252,8 +1317,6 @@       A.Lit{}        -> True       A.Pi{}         -> True       A.Fun{}        -> True-      A.Set{}        -> True-      A.Prop{}       -> True       A.Rec{}        -> True       A.RecUpdate{}  -> True       A.ScopedExpr{} -> __IMPOSSIBLE__@@ -1272,7 +1335,7 @@       q  <- quoteTerm et'       ty <- el primAgdaTerm       coerce cmp q ty t-    metas -> postponeTypeCheckingProblem (DoQuoteTerm cmp et t) $ andM $ map isInstantiatedMeta metas+    metas -> postponeTypeCheckingProblem (DoQuoteTerm cmp et t) $ unblockOnAllMetas $ Set.fromList metas  -- | Unquote a TCM computation in a given hole. unquoteM :: A.Expr -> Term -> Type -> TCM ()@@ -1289,18 +1352,15 @@     , nest 2 $ "on" <+> prettyTCM hole <+> ":" <+> prettyTCM goal ]   ok  <- runUnquoteM $ unquoteTCM tac hole   case ok of-    Left (BlockedOnMeta oldState x) -> do+    Left (BlockedOnMeta oldState blocker) -> do       putTC oldState-      mi <- lookupMeta' x-      (r, meta) <- case mi of-        Nothing -> do -- fresh meta: need to block on something else!-          (noRange,) . firstMeta <$> instantiateFull goal-            -- Remark:-            -- Nothing:  Nothing to block on, leave it yellow. Alternative: fail.-            -- Just x:   range?-        Just mi -> return (getRange mi, Just x)+      let stripFreshMeta x = maybe neverUnblock (const $ unblockOnMeta x) <$> lookupMeta' x+      blocker' <- onBlockingMetasM stripFreshMeta blocker+      r <- case Set.toList $ allBlockingMetas blocker' of+            x : _ -> getRange <$> lookupMeta' x+            []    -> return noRange       setCurrentRange r $-        addConstraint (UnquoteTactic meta tac hole goal)+        addConstraint blocker' (UnquoteTactic tac hole goal)     Left err -> typeError $ UnquoteFailed err     Right _ -> return () @@ -1376,7 +1436,7 @@ --   by inserting an underscore for the missing type. domainFree :: ArgInfo -> A.Binder' A.Name -> A.LamBinding domainFree info x =-  A.DomainFull $ A.mkTBind r [unnamedArg info $ fmap A.mkBindName x]+  A.DomainFull $ A.mkTBind r (singleton $ unnamedArg info $ fmap A.mkBindName x)                $ A.Underscore underscoreInfo   where     r = getRange x@@ -1487,7 +1547,7 @@  defOrVar :: A.Expr -> Bool defOrVar A.Var{} = True-defOrVar A.Def{} = True+defOrVar A.Def'{} = True defOrVar A.Proj{} = True defOrVar (A.ScopedExpr _ e) = defOrVar e defOrVar _     = False@@ -1510,52 +1570,56 @@ -- | Infer the type of an expression, and if it is of the form --   @{tel} -> D vs@ for some datatype @D@ then insert the hidden --   arguments.  Otherwise, leave the type polymorphic.-inferExprForWith :: A.Expr -> TCM (Term, Type)-inferExprForWith e = do-  reportSDoc "tc.with.infer" 20 $ "inferExprforWith " <+> prettyTCM e-  reportSLn  "tc.with.infer" 80 $ "inferExprforWith " ++ show (deepUnscope e)-  traceCall (InferExpr e) $ do-    -- With wants type and term fully instantiated!-    (v, t) <- instantiateFull =<< inferExpr e-    v0 <- reduce v-    -- Andreas 2014-11-06, issue 1342.-    -- Check that we do not `with` on a module parameter!-    case v0 of-      Var i [] -> whenM (isModuleFreeVar i) $ do-        reportSDoc "tc.with.infer" 80 $ vcat-          [ 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-          , "current context = " <+> do prettyTCM =<< getContextTelescope-          ]-        typeError $ WithOnFreeVariable e v0-      _        -> return ()-    -- Possibly insert hidden arguments.-    TelV tel t0 <- telViewUpTo' (-1) (not . visible) t-    case unEl t0 of-      Def d vs -> do-        res <- isDataOrRecordType d-        case res of-          Nothing -> return (v, t)-          Just{}  -> do-            (args, t1) <- implicitArgs (-1) notVisible t-            return (v `apply` args, t1)-      _ -> return (v, t)+inferExprForWith :: Arg A.Expr -> TCM (Term, Type)+inferExprForWith (Arg info e) =+  applyRelevanceToContext (getRelevance info) $ do+    reportSDoc "tc.with.infer" 20 $ "inferExprforWith " <+> prettyTCM e+    reportSLn  "tc.with.infer" 80 $ "inferExprforWith " ++ show (deepUnscope e)+    traceCall (InferExpr e) $ do+      -- With wants type and term fully instantiated!+      (v, t) <- instantiateFull =<< inferExpr e+      v0 <- reduce v+      -- Andreas 2014-11-06, issue 1342.+      -- Check that we do not `with` on a module parameter!+      case v0 of+        Var i [] -> whenM (isModuleFreeVar i) $ do+          reportSDoc "tc.with.infer" 80 $ vcat+            [ 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+            , "current context = " <+> do prettyTCM =<< getContextTelescope+            ]+          typeError $ WithOnFreeVariable e v0+        _        -> return ()+      -- Possibly insert hidden arguments.+      TelV tel t0 <- telViewUpTo' (-1) (not . visible) t+      case unEl t0 of+        Def d vs -> do+          res <- isDataOrRecordType d+          case res of+            Nothing -> return (v, t)+            Just{}  -> do+              (args, t1) <- implicitArgs (-1) notVisible t+              return (v `apply` args, t1)+        _ -> return (v, t)  --------------------------------------------------------------------------- -- * Let bindings --------------------------------------------------------------------------- -checkLetBindings :: [A.LetBinding] -> TCM a -> TCM a-checkLetBindings = foldr (.) id . map checkLetBinding+checkLetBindings :: Foldable t => t A.LetBinding -> TCM a -> TCM a+checkLetBindings = foldr ((.) . checkLetBinding) id  checkLetBinding :: A.LetBinding -> TCM a -> TCM a  checkLetBinding b@(A.LetBind i info x t e) ret =   traceCall (CheckLetBinding b) $ do+    -- #4131: Only DontExpandLast if no user written type signature+    let check | getOrigin info == Inserted = checkDontExpandLast+              | otherwise                  = checkExpr'     t <- isType_ t-    v <- applyModalityToContext info $ checkDontExpandLast CmpLeq e t+    v <- applyModalityToContext info $ check CmpLeq e t     addLetBinding info (A.unBind x) v t ret  checkLetBinding b@(A.LetPatBind i p e) ret =@@ -1634,11 +1698,11 @@   fv   <- getCurrentModuleFreeVars   n    <- getContextSize   let new = n - fv-  reportSLn "tc.term.let.apply" 10 $ "Applying " ++ show modapp ++ " with " ++ show new ++ " free variables"+  reportSDoc "tc.term.let.apply" 10 $ "Applying" <+> pretty x <+> prettyA modapp <?> ("with" <+> pshow new <+> "free variables")   reportSDoc "tc.term.let.apply" 20 $ vcat     [ "context =" <+> (prettyTCM =<< getContextTelescope)     , "module  =" <+> (prettyTCM =<< currentModule)-    , "fv      =" <+> (text $ show fv)+    , "fv      =" <+> text (show fv)     ]   checkSectionApplication i x modapp copyInfo   withAnonymousModule x new ret

src/full/Agda/TypeChecking/Rules/Term.hs-boot view

@@ -5,6 +5,7 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base+import Agda.Utils.List1 (List1)  isType_ :: A.Expr -> TCM Type @@ -12,7 +13,7 @@ checkExpr' :: Comparison -> A.Expr -> Type -> TCM Term inferExpr :: A.Expr -> TCM (Term, Type) -checkPostponedLambda :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term+checkPostponedLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> A.Expr -> Type -> TCM Term  doQuoteTerm :: Comparison -> Term -> Type -> TCM Term unquoteTactic :: Term -> Term -> Type -> TCM ()

src/full/Agda/TypeChecking/Serialise.hs view

@@ -30,6 +30,7 @@ import Control.DeepSeq import qualified Control.Exception as E import Control.Monad+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State.Strict @@ -44,7 +45,9 @@ import qualified Data.Binary.Put as B import qualified Data.List as List import Data.Function-import Data.Monoid+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup((<>))+#endif  import qualified Codec.Compression.GZip as G import qualified Codec.Compression.Zlib.Internal as Z@@ -53,8 +56,6 @@ import GHC.Compact as C #endif -import Agda.Interaction.Options- import qualified Agda.TypeChecking.Monad.Benchmark as Bench  import Agda.TypeChecking.Serialise.Base@@ -62,18 +63,16 @@  import Agda.TypeChecking.Monad +import Agda.Utils.FileName (canonicalizeAbsolutePath) import Agda.Utils.Hash import Agda.Utils.IORef -import Agda.Utils.Except-import Agda.Utils.Monad- -- Note that the Binary instance for Int writes 64 bits, but throws -- away the 32 high bits when reading (at the time of writing, on -- 32-bit machines). Word64 does not have these problems.  currentInterfaceVersion :: Word64-currentInterfaceVersion = 20200305 * 10 + 0+currentInterfaceVersion = 20210510 * 10 + 0  -- | The result of 'encode' and 'encodeInterface'. @@ -92,40 +91,42 @@ encode a = do     collectStats <- hasVerbosity "profile.serialize" 20     fileMod <- sourceToModule-    newD@(Dict nD sD bD iD dD _tD+    newD@(Dict nD ltD stD bD iD dD _tD       _nameD       _qnameD-      nC sC bC iC dC tC+      nC ltC stC bC iC dC tC       nameC       qnameC       stats _ _) <- liftIO $ emptyDict collectStats     root <- liftIO $ (`runReaderT` newD) $ do        icodeFileMod fileMod  -- Only fills absPathD from fileMod        icode a-    nL <- benchSort $ l nD-    sL <- benchSort $ l sD-    bL <- benchSort $ l bD-    iL <- benchSort $ l iD-    dL <- benchSort $ l dD+    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.     verboseS "profile.sharing" 10 $ do       statistics "pointers" tC     verboseS "profile.serialize" 10 $ do-      statistics "Integer"  iC-      statistics "String"   sC-      statistics "Text"     bC-      statistics "Double"   dC-      statistics "Node"     nC+      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+      statistics "A.QName"     qnameC+      statistics "A.Name"      nameC     when collectStats $ do       stats <- Map.fromList . map (second toInteger) <$> do         liftIO $ H.toList stats       modifyStatistics $ Map.union stats     -- Encode hashmaps and root, and compress.     bits1 <- Bench.billTo [ Bench.Serialization, Bench.BinaryEncode ] $-      return $!! B.encode (root, nL, sL, bL, iL, dL)+      return $!! B.encode (root, nL, ltL, stL, bL, iL, dL)     let compressParams = G.defaultCompressParams           { G.compressLevel    = G.bestSpeed           , G.compressStrategy = G.huffmanOnlyStrategy@@ -182,20 +183,18 @@    (mf, r) <- liftIO $ E.handle (\(E.ErrorCall s) -> noResult s) $ do -    ((r, nL, sL, bL, iL, dL), s, _) <- return $ runGetState B.get s 0+    ((r, nL, ltL, stL, bL, iL, dL), s, _) <- return $ runGetState B.get s 0     if s /= L.empty      then noResult "Garbage at end."      else do -      st <- St (ar nL) (ar sL) (ar bL) (ar iL) (ar dL)+      st <- St (ar nL) (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL)               <$> liftIO H.new               <*> return mf <*> return incs       (r, st) <- runStateT (runExceptT (value r)) st       return (Just $ modFile st, r) -  case mf of-    Nothing -> return ()-    Just mf -> stModuleToSource `setTCLens` mf+  forM_ mf (setTCLens stModuleToSource)    case r of     Right x -> do@@ -300,5 +299,8 @@ icodeFileMod fileMod = do   hmap <- asks absPathD   forM_ (Map.toList fileMod) $ \ (absolutePath, topLevelModuleName) -> do+    -- Andreas, 2020-08-11, issue #4828.+    -- Expand symlinks before storing in the dictonary.+    absolutePath <- liftIO $ canonicalizeAbsolutePath absolutePath     i <- icod_ topLevelModuleName     liftIO $ H.insert hmap absolutePath i

src/full/Agda/TypeChecking/Serialise/Base.hs view

@@ -1,14 +1,14 @@ {-# LANGUAGE CPP                  #-}-{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE TypeOperators        #-} {-# LANGUAGE DataKinds            #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-} -- Due to ICODE vararg typeclass  module Agda.TypeChecking.Serialise.Base where  import Control.Exception (evaluate)  import Control.Monad.Catch (catchAll)+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State.Strict (StateT, gets) @@ -22,8 +22,9 @@ import Data.Maybe import qualified Data.Binary as B import qualified Data.Binary.Get as B-import Data.Text.Lazy (Text)-import Data.Typeable ( cast, Typeable, typeOf, TypeRep )+import qualified Data.Text      as T+import qualified Data.Text.Lazy as TL+import Data.Typeable ( cast, Typeable, TypeRep, typeRep )  import Agda.Syntax.Common (NameId) import Agda.Syntax.Internal (Term, QName(..), ModuleName(..), nameId)@@ -34,7 +35,6 @@ import Agda.Utils.Lens import Agda.Utils.Monad import Agda.Utils.Pointer-import Agda.Utils.Except (ExceptT, throwError) import Agda.Utils.TypeLevel  -- | Constructor tag (maybe omitted) and argument indices.@@ -93,7 +93,8 @@   -- Dictionaries which are serialized:   { nodeD        :: !(HashTable Node    Int32)    -- ^ Written to interface file.   , stringD      :: !(HashTable String  Int32)    -- ^ Written to interface file.-  , textD        :: !(HashTable Text    Int32)    -- ^ Written to interface file.+  , lTextD       :: !(HashTable TL.Text Int32)    -- ^ Written to interface file.+  , sTextD       :: !(HashTable T.Text  Int32)    -- ^ Written to interface file.   , integerD     :: !(HashTable Integer Int32)    -- ^ Written to interface file.   , doubleD      :: !(HashTable Double  Int32)    -- ^ Written to interface file.   -- Dicitionaries which are not serialized, but provide@@ -106,7 +107,8 @@   -- Fresh UIDs and reuse statistics:   , nodeC        :: !(IORef FreshAndReuse)  -- counters for fresh indexes   , stringC      :: !(IORef FreshAndReuse)-  , textC        :: !(IORef FreshAndReuse)+  , lTextC       :: !(IORef FreshAndReuse)+  , sTextC       :: !(IORef FreshAndReuse)   , integerC     :: !(IORef FreshAndReuse)   , doubleC      :: !(IORef FreshAndReuse)   , termC        :: !(IORef FreshAndReuse)@@ -133,6 +135,7 @@   <*> H.new   <*> H.new   <*> H.new+  <*> H.new   <*> newIORef farEmpty   <*> newIORef farEmpty   <*> newIORef farEmpty@@ -141,6 +144,7 @@   <*> newIORef farEmpty   <*> newIORef farEmpty   <*> newIORef farEmpty+  <*> newIORef farEmpty   <*> H.new   <*> pure collectStats   <*> H.new@@ -155,7 +159,8 @@ data St = St   { nodeE     :: !(Array Int32 Node)     -- ^ Obtained from interface file.   , stringE   :: !(Array Int32 String)   -- ^ Obtained from interface file.-  , textE     :: !(Array Int32 Text)     -- ^ Obtained from interface file.+  , lTextE    :: !(Array Int32 TL.Text)  -- ^ Obtained from interface file.+  , sTextE    :: !(Array Int32 T.Text)   -- ^ Obtained from interface file.   , integerE  :: !(Array Int32 Integer)  -- ^ Obtained from interface file.   , doubleE   :: !(Array Int32 Double)   -- ^ Obtained from interface file.   , nodeMemo  :: !Memo@@ -204,7 +209,7 @@ -- | Increase entry for @a@ in 'stats'. tickICode :: forall a. Typeable a => a -> S () tickICode _ = whenM (asks collectStats) $ do-    let key = "icode " ++ show (typeOf (undefined :: a))+    let key = "icode " ++ show (typeRep (Proxy :: Proxy a))     hmap <- asks stats     liftIO $ do       n <- fromMaybe 0 <$> H.lookup hmap key@@ -371,7 +376,7 @@ vcase valu = \ix -> do     memo <- gets nodeMemo     -- compute run-time representation of type a-    let aTyp = typeOf (undefined :: a)+    let aTyp = typeRep (Proxy :: Proxy a)     -- to introduce sharing, see if we have seen a thing     -- represented by ix before     maybeU <- liftIO $ H.lookup memo (ix, aTyp)

src/full/Agda/TypeChecking/Serialise/Instances.hs view

@@ -3,20 +3,30 @@ -- Only instances exported module Agda.TypeChecking.Serialise.Instances () where +import Agda.Syntax.Position+import Agda.Syntax.Abstract.Name import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Serialise.Base---import Agda.TypeChecking.Serialise.Instances.Abstract ()---import Agda.TypeChecking.Serialise.Instances.Common ()---import Agda.TypeChecking.Serialise.Instances.Compilers ()+import Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) import Agda.TypeChecking.Serialise.Instances.Highlighting ()---import Agda.TypeChecking.Serialise.Instances.Internal () import Agda.TypeChecking.Serialise.Instances.Errors ()+import Agda.Utils.Hash +type RangedImportedModules = [(SerialisedRange, ModuleName, Hash)]++fromImportedModules :: [(ModuleName, Hash)] -> RangedImportedModules+fromImportedModules ms = [(SerialisedRange $ getRange x, x, hash) | (x, hash) <- ms]++toImportedModules :: RangedImportedModules -> [(ModuleName, Hash)]+toImportedModules ms = [(setRange (underlyingRange r) x, hash) | (r, x, hash) <- ms]+ instance EmbPrj Interface where-  icod_ (Interface a b c d e f g h i j k l m n o p q r s) =-    icodeN' Interface a b c d e f g h i j k l m n o p q r s+  icod_ (Interface a b c d e f g h i j k l m n o p q r s t) =+      icodeN' interface a b c (fromImportedModules d) e f g h i j k l m n o p q r s t+    where interface a b c = Interface a b c . toImportedModules    value = vcase valu where-    valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s] =-      valuN Interface a b c d e f g h i j k l m n o p q r s+    valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t] =+        valuN interface a b c d e f g h i j k l m n o p q r s t+      where interface a b c = Interface a b c . toImportedModules     valu _ = malformed

src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs view

@@ -29,6 +29,15 @@    value = valueN Scope +instance EmbPrj DataOrRecordModule where+  icod_ IsDataModule   = icodeN' IsDataModule+  icod_ IsRecordModule = icodeN 0 IsRecordModule++  value = vcase $ \case+    []  -> valuN IsDataModule+    [0] -> valuN IsRecordModule+    _   -> malformed+ instance EmbPrj NameSpaceId where   icod_ PublicNS        = icodeN' PublicNS   icod_ PrivateNS       = icodeN 1 PrivateNS@@ -96,6 +105,15 @@     valu [a] = valuN GeneralizedVarsMetadata a     valu _   = malformed +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+ instance EmbPrj AbstractModule where   icod_ (AbsModule a b) = icodeN' AbsModule a b @@ -128,11 +146,13 @@   icod_ LambdaBound   = icodeN' LambdaBound   icod_ PatternBound  = icodeN 1 PatternBound   icod_ LetBound      = icodeN 2 LetBound+  icod_ WithBound     = icodeN 3 WithBound    value = vcase valu where     valu []  = valuN LambdaBound     valu [1] = valuN PatternBound     valu [2] = valuN LetBound+    valu [3] = valuN WithBound     valu _   = malformed  instance EmbPrj LocalVar where@@ -156,12 +176,13 @@   icod_ (A.AsP p a b)         = icodeN 4 (A.AsP p) a b   icod_ (A.DotP p a)          = icodeN 5 (A.DotP p) a   icod_ t@(A.AbsurdP _)       = icodeN 6 t-  icod_ (A.LitP a)            = icodeN 7 A.LitP a+  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 p a)          = icodeN 10 (A.RecP p) a   icod_ (A.EqualP _ a)        = __IMPOSSIBLE__   icod_ (A.WithP i a)         = icodeN 11 (A.WithP i) a+  icod_ (A.AnnP i a p)        = icodeN 12 (A.AnnP i) a p    value = vcase valu where     valu [0, a]       = valuN A.VarP a@@ -171,11 +192,12 @@     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) a+    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]      = valuN (A.RecP i) a     valu [11, a]      = valuN (A.WithP i) a+    valu [12, a, b]   = valuN (A.AnnP i) a b     valu _            = malformed      i = patNoRange

src/full/Agda/TypeChecking/Serialise/Instances/Common.hs view

@@ -1,11 +1,10 @@- {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}  module Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) where -import Prelude hiding (mapM)--import Control.Monad.Reader hiding (mapM)+import Control.Monad.Except+import Control.Monad.Reader import Control.Monad.State.Strict (gets, modify)  @@ -26,8 +25,9 @@ import qualified Data.Set as Set import Data.Sequence (Seq) import qualified Data.Sequence as Seq-import Data.Text.Lazy (Text)-import Data.Traversable ( mapM )+import Data.Strict.Tuple (Pair(..))+import qualified Data.Text      as T+import qualified Data.Text.Lazy as TL import Data.Typeable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap@@ -38,9 +38,7 @@ import Agda.Syntax.Concrete.Name as C import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Info import Agda.Syntax.Position as P-import Agda.Syntax.Notation import Agda.Syntax.Literal import Agda.Interaction.FindFile @@ -48,29 +46,30 @@  import Agda.Utils.BiMap (BiMap) import qualified Agda.Utils.BiMap as BiMap+import qualified Agda.Utils.Empty as Empty import Agda.Utils.FileName+import Agda.Utils.List2 (List2(List2))+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Trie (Trie(..))---import Agda.Utils.Except--import Agda.Utils.Empty (Empty)-import qualified Agda.Utils.Empty as Empty- import Agda.Utils.WithDefault  import Agda.Utils.Impossible+import Agda.Utils.CallStack  instance {-# OVERLAPPING #-} EmbPrj String where   icod_   = icodeString   value i = (! i) `fmap` gets stringE -instance EmbPrj Text where-  icod_   = icodeX textD textC-  value i = (! i) `fmap` gets textE+instance EmbPrj TL.Text where+  icod_   = icodeX lTextD lTextC+  value i = (! i) `fmap` gets lTextE +instance EmbPrj T.Text where+  icod_   = icodeX sTextD sTextC+  value i = (! i) `fmap` gets sTextE+ instance EmbPrj Integer where   icod_   = icodeInteger   value i = (! i) `fmap` gets integerE@@ -118,6 +117,11 @@    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 @@ -155,11 +159,11 @@     valu _   = malformed  instance EmbPrj FileType where-  icod_ AgdaFileType = icodeN' IsData-  icod_ MdFileType   = icodeN 0 IsRecord-  icod_ RstFileType  = icodeN 1 IsRecord-  icod_ TexFileType  = icodeN 2 IsRecord-  icod_ OrgFileType  = icodeN 3 IsRecord+  icod_ AgdaFileType = icodeN'  AgdaFileType+  icod_ MdFileType   = icodeN 0 MdFileType+  icod_ RstFileType  = icodeN 1 RstFileType+  icod_ TexFileType  = icodeN 2 TexFileType+  icod_ OrgFileType  = icodeN 3 OrgFileType    value = vcase $ \case     []  -> valuN AgdaFileType@@ -169,18 +173,13 @@     [3] -> valuN OrgFileType     _   -> malformed -instance EmbPrj DataOrRecord where-  icod_ IsData   = icodeN' IsData-  icod_ IsRecord = icodeN 0 IsRecord--  value = vcase $ \case-    []  -> valuN IsData-    [0] -> valuN IsRecord-    _   -> malformed- instance EmbPrj AbsolutePath where   icod_ file = do     d <- asks absPathD+    -- Andreas, 2020-08-11, issue #4828+    -- AbsolutePath is no longer canonical (can contain symlinks).+    -- The dictonary contains canonical pathes, though.+    file <- liftIO $ canonicalizeAbsolutePath file     liftIO $ flip fromMaybeM (H.lookup d file) $ do       -- The path @file@ should be cached in the dictionary @d@.       -- This seems not to be the case, thus, crash here.@@ -190,7 +189,7 @@         [ "Panic while serializing absolute path: " ++ show file         , "The path could not be found in the dictionary:"         ]-      putStrLn . show =<< H.toList d+      print =<< H.toList d       __IMPOSSIBLE__    value m = do@@ -237,10 +236,15 @@   icod_ = icod_ . NonEmpty.toList   value = maybe malformed return . nonEmpty <=< value -instance (Ord a, Ord b, EmbPrj a, EmbPrj b) => EmbPrj (BiMap a b) where-  icod_ m = icode (BiMap.toList m)-  value m = BiMap.fromList <$> value m+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+ instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where   icod_ m = icode (Map.toList m)   value m = Map.fromList `fmap` value m@@ -392,10 +396,10 @@   value n           = A.MName `fmap` value n  instance EmbPrj A.Name where-  icod_ (A.Name a b c d e) = icodeMemo nameD nameC a $-    icodeN' (\ a b -> A.Name a b . underlyingRange) a b (SerialisedRange c) d e+  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 -  value = valueN (\a b c -> A.Name a b (underlyingRange c))+  value = valueN (\a b c d -> A.Name a b c (underlyingRange d))  instance EmbPrj a => EmbPrj (C.FieldAssignment' a) where   icod_ (C.FieldAssignment a b) = icodeN' C.FieldAssignment a b@@ -413,10 +417,15 @@   value = valueN Ranged  instance EmbPrj ArgInfo where-  icod_ (ArgInfo h r o fv) = icodeN' ArgInfo h r o fv+  icod_ (ArgInfo h r o fv ann) = icodeN' ArgInfo h r o fv ann    value = valueN ArgInfo +instance EmbPrj ModuleNameHash where+  icod_ (ModuleNameHash a) = icodeN' ModuleNameHash a++  value = valueN ModuleNameHash+ instance EmbPrj NameId where   icod_ (NameId a b) = icodeN' NameId a b @@ -436,15 +445,17 @@    value = valueN Arg -instance EmbPrj HasEta where-  icod_ YesEta = icodeN' YesEta-  icod_ NoEta  = icodeN 1 NoEta+instance EmbPrj a => EmbPrj (HasEta' a) where+  icod_ YesEta    = icodeN' YesEta+  icod_ (NoEta a) = icodeN' NoEta a    value = vcase valu where     valu []  = valuN YesEta-    valu [1] = valuN NoEta+    valu [a] = valuN NoEta a     valu _   = malformed +instance EmbPrj PatternOrCopattern+ instance EmbPrj Induction where   icod_ Inductive   = icodeN' Inductive   icod_ CoInductive = icodeN 1 CoInductive@@ -552,6 +563,21 @@   value 2 = return NonStrict   value _ = malformed +instance EmbPrj Annotation where+  icod_ (Annotation l) = icodeN' Annotation l++  value = vcase $ \case+    [l] -> valuN Annotation l+    _ -> malformed++instance EmbPrj Lock where+  icod_ IsNotLock = return 0+  icod_ IsLock    = return 1++  value 0 = return IsNotLock+  value 1 = return IsLock+  value _ = malformed+ instance EmbPrj Origin where   icod_ UserWritten = return 0   icod_ Inserted    = return 1@@ -603,22 +629,22 @@   value _ = malformed  instance EmbPrj Agda.Syntax.Literal.Literal where-  icod_ (LitNat    a b)   = icodeN' LitNat a b-  icod_ (LitFloat  a b)   = icodeN 1 LitFloat a b-  icod_ (LitString a b)   = icodeN 2 LitString a b-  icod_ (LitChar   a b)   = icodeN 3 LitChar a b-  icod_ (LitQName  a b)   = icodeN 5 LitQName a b-  icod_ (LitMeta   a b c) = icodeN 6 LitMeta a b c-  icod_ (LitWord64 a b)   = icodeN 7 LitWord64 a b+  icod_ (LitNat    a)   = icodeN' LitNat a+  icod_ (LitFloat  a)   = icodeN 1 LitFloat a+  icod_ (LitString a)   = icodeN 2 LitString a+  icod_ (LitChar   a)   = icodeN 3 LitChar a+  icod_ (LitQName  a)   = icodeN 5 LitQName a+  icod_ (LitMeta   a b) = icodeN 6 LitMeta a b+  icod_ (LitWord64 a)   = icodeN 7 LitWord64 a    value = vcase valu where-    valu [a, b]       = valuN LitNat    a b-    valu [1, a, b]    = valuN LitFloat  a b-    valu [2, a, b]    = valuN LitString a b-    valu [3, a, b]    = valuN LitChar   a b-    valu [5, a, b]    = valuN LitQName  a b-    valu [6, a, b, c] = valuN LitMeta   a b c-    valu [7, a, b]    = valuN LitWord64 a b+    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  instance EmbPrj IsAbstract where@@ -639,21 +665,24 @@     valu []  = valuN NotDelayed     valu _   = malformed +instance EmbPrj SrcLoc where+  icod_ (SrcLoc p m f sl sc el ec) = icodeN' SrcLoc p m f sl sc el ec+  value = valueN SrcLoc++instance EmbPrj CallStack where+  icod_ = icode . getCallStack+  value = fmap fromCallSiteList . value+ instance EmbPrj Impossible where-  icod_ (Impossible a b)  = icodeN 0 Impossible a b-  icod_ (Unreachable a b) = icodeN 1 Unreachable a b+  icod_ (Impossible a)              = icodeN 0 Impossible a+  icod_ (Unreachable a)             = icodeN 1 Unreachable a   icod_ (ImpMissingDefinitions a b) = icodeN 2 ImpMissingDefinitions a b    value = vcase valu where-    valu [0, a, b] = valuN Impossible  a b-    valu [1, a, b] = valuN Unreachable a b+    valu [0, a]    = valuN Impossible  a+    valu [1, a]    = valuN Unreachable a     valu [2, a, b] = valuN ImpMissingDefinitions a b     valu _         = malformed--instance EmbPrj Empty where-  icod_ a = icod_ =<< lift (Empty.toImpossible a)--  value = fmap throwImpossible . value  instance EmbPrj ExpandedEllipsis where   icod_ NoEllipsis = icodeN' NoEllipsis

src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs view

@@ -8,106 +8,155 @@ import Agda.TypeChecking.Serialise.Instances.Internal () --instance only import Agda.TypeChecking.Serialise.Instances.Abstract () --instance only -import Agda.Syntax.Concrete.Definitions (DeclarationWarning(..))+import Agda.Syntax.Concrete.Definitions (DeclarationWarning(..), DeclarationWarning'(..))+import Agda.Syntax.Parser.Monad import Agda.TypeChecking.Monad.Base import Agda.Interaction.Options import Agda.Interaction.Options.Warnings-import Agda.Interaction.Library-import Agda.Interaction.Library.Parse+import Agda.Interaction.Library.Base import Agda.Termination.CutOff import Agda.Utils.Pretty  import Agda.Utils.Impossible  instance EmbPrj TCWarning where-  icod_ (TCWarning a b c d) = icodeN' TCWarning a b c d-+  icod_ (TCWarning fp a b c d) = icodeN' TCWarning fp a b c d   value = valueN TCWarning  -- We don't need to serialise warnings that turn into errors instance EmbPrj Warning where-  icod_ (TerminationIssue a)         = __IMPOSSIBLE__-  icod_ (UnreachableClauses a b)     = icodeN 0 UnreachableClauses a b-  icod_ (CoverageIssue a b)          = __IMPOSSIBLE__-  icod_ (NotStrictlyPositive a b)    = __IMPOSSIBLE__-  icod_ (UnsolvedMetaVariables a)    = __IMPOSSIBLE__-  icod_ (UnsolvedInteractionMetas a) = __IMPOSSIBLE__-  icod_ (UnsolvedConstraints a)      = __IMPOSSIBLE__-  icod_ (OldBuiltin a b)             = icodeN 1 OldBuiltin a b-  icod_ EmptyRewritePragma           = icodeN 2 EmptyRewritePragma-  icod_ UselessPublic                = icodeN 3 UselessPublic-  icod_ (UselessInline a)            = icodeN 4 UselessInline a-  icod_ (GenericWarning a)           = icodeN 5 GenericWarning a-  icod_ (GenericNonFatalError a)     = __IMPOSSIBLE__-  icod_ (SafeFlagPostulate a)        = __IMPOSSIBLE__-  icod_ (SafeFlagPragma a)           = __IMPOSSIBLE__-  icod_ SafeFlagNonTerminating       = __IMPOSSIBLE__-  icod_ SafeFlagTerminating          = __IMPOSSIBLE__-  icod_ SafeFlagWithoutKFlagPrimEraseEquality    = __IMPOSSIBLE__-  icod_ SafeFlagNoPositivityCheck    = __IMPOSSIBLE__-  icod_ SafeFlagPolarity             = __IMPOSSIBLE__-  icod_ SafeFlagNoUniverseCheck      = __IMPOSSIBLE__-  icod_ SafeFlagNoCoverageCheck      = __IMPOSSIBLE__-  icod_ SafeFlagInjective            = __IMPOSSIBLE__-  icod_ SafeFlagEta                  = __IMPOSSIBLE__-  icod_ (ParseWarning a)             = __IMPOSSIBLE__-  icod_ (DeprecationWarning a b c)   = icodeN 6 DeprecationWarning a b c-  icod_ (NicifierIssue a)            = icodeN 7 NicifierIssue a-  icod_ (InversionDepthReached a)    = icodeN 8 InversionDepthReached a-  icod_ (UserWarning a)              = icodeN 9 UserWarning a-  icod_ (AbsurdPatternRequiresNoRHS a) = icodeN 10 AbsurdPatternRequiresNoRHS a-  icod_ (ModuleDoesntExport a b)       = icodeN 11 ModuleDoesntExport a b-  icod_ (LibraryWarning a)           = icodeN 12 LibraryWarning a-  icod_ (CoverageNoExactSplit a b)   = icodeN 13 CoverageNoExactSplit a b-  icod_ (CantGeneralizeOverSorts a)  = icodeN 14 CantGeneralizeOverSorts a-  icod_ (IllformedAsClause a)        = icodeN 15 IllformedAsClause a-  icod_ WithoutKFlagPrimEraseEquality = icodeN 16 WithoutKFlagPrimEraseEquality-  icod_ (InstanceWithExplicitArg a)  = icodeN 17 InstanceWithExplicitArg a-  icod_ (InfectiveImport a b)          = icodeN 18 InfectiveImport a b-  icod_ (CoInfectiveImport a b)        = icodeN 19 CoInfectiveImport a b-  icod_ (InstanceNoOutputTypeName a) = icodeN 20 InstanceNoOutputTypeName a-  icod_ (InstanceArgWithExplicitArg a) = icodeN 21 InstanceArgWithExplicitArg a-  icod_ WrongInstanceDeclaration     = icodeN 22 WrongInstanceDeclaration-  icod_ (RewriteNonConfluent a b c d) = icodeN 23 RewriteNonConfluent a b c d-  icod_ (RewriteMaybeNonConfluent a b c) = icodeN 24 RewriteMaybeNonConfluent a b c-  icod_ (PragmaCompileErased a b)        = icodeN 25 PragmaCompileErased a b-  icod_ (FixityInRenamingModule a)       = icodeN 26 FixityInRenamingModule a-  icod_ (NotInScopeW ns)                 = icodeN 27 NotInScopeW ns-  icod_ (ClashesViaRenaming a b)         = icodeN 28 ClashesViaRenaming a b+  icod_ = \case+    TerminationIssue a                    -> __IMPOSSIBLE__+    UnreachableClauses a b                -> icodeN 0 UnreachableClauses a b+    CoverageIssue a b                     -> __IMPOSSIBLE__+    NotStrictlyPositive a b               -> __IMPOSSIBLE__+    UnsolvedMetaVariables a               -> __IMPOSSIBLE__+    UnsolvedInteractionMetas a            -> __IMPOSSIBLE__+    UnsolvedConstraints a                 -> __IMPOSSIBLE__+    OldBuiltin a b                        -> icodeN 1 OldBuiltin a b+    EmptyRewritePragma                    -> icodeN 2 EmptyRewritePragma+    UselessPublic                         -> icodeN 3 UselessPublic+    UselessInline a                       -> icodeN 4 UselessInline a+    GenericWarning a                      -> icodeN 5 GenericWarning a+    GenericNonFatalError a                -> __IMPOSSIBLE__+    SafeFlagPostulate a                   -> __IMPOSSIBLE__+    SafeFlagPragma a                      -> __IMPOSSIBLE__+    SafeFlagNonTerminating                -> __IMPOSSIBLE__+    SafeFlagTerminating                   -> __IMPOSSIBLE__+    SafeFlagWithoutKFlagPrimEraseEquality -> __IMPOSSIBLE__+    SafeFlagNoPositivityCheck             -> __IMPOSSIBLE__+    SafeFlagPolarity                      -> __IMPOSSIBLE__+    SafeFlagNoUniverseCheck               -> __IMPOSSIBLE__+    SafeFlagNoCoverageCheck               -> __IMPOSSIBLE__+    SafeFlagInjective                     -> __IMPOSSIBLE__+    SafeFlagEta                           -> __IMPOSSIBLE__+    DeprecationWarning a b c              -> icodeN 6 DeprecationWarning a b c+    NicifierIssue a                       -> icodeN 7 NicifierIssue a+    InversionDepthReached a               -> icodeN 8 InversionDepthReached a+    UserWarning a                         -> icodeN 9 UserWarning a+    AbsurdPatternRequiresNoRHS a          -> icodeN 10 AbsurdPatternRequiresNoRHS a+    ModuleDoesntExport a b c d            -> icodeN 11 ModuleDoesntExport a b c d+    LibraryWarning a                      -> icodeN 12 LibraryWarning a+    CoverageNoExactSplit a b              -> icodeN 13 CoverageNoExactSplit a b+    CantGeneralizeOverSorts a             -> icodeN 14 CantGeneralizeOverSorts a+    IllformedAsClause a                   -> icodeN 15 IllformedAsClause a+    WithoutKFlagPrimEraseEquality         -> icodeN 16 WithoutKFlagPrimEraseEquality+    InstanceWithExplicitArg a             -> icodeN 17 InstanceWithExplicitArg a+    InfectiveImport a b                   -> icodeN 18 InfectiveImport a b+    CoInfectiveImport a b                 -> icodeN 19 CoInfectiveImport a b+    InstanceNoOutputTypeName a            -> icodeN 20 InstanceNoOutputTypeName a+    InstanceArgWithExplicitArg a          -> icodeN 21 InstanceArgWithExplicitArg a+    WrongInstanceDeclaration              -> icodeN 22 WrongInstanceDeclaration+    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+    FixityInRenamingModule a              -> icodeN 26 FixityInRenamingModule a+    NotInScopeW ns                        -> icodeN 27 NotInScopeW ns+    ClashesViaRenaming a b                -> icodeN 28 ClashesViaRenaming a b+    RecordFieldWarning a                  -> icodeN 29 RecordFieldWarning a+    UselessPatternDeclarationForRecord a  -> icodeN 30 UselessPatternDeclarationForRecord a+    EmptyWhere                            -> icodeN 31 EmptyWhere+    AsPatternShadowsConstructorOrPatternSynonym a -> icodeN 32 AsPatternShadowsConstructorOrPatternSynonym a+    DuplicateUsing a                      -> icodeN 33 DuplicateUsing a+    UselessHiding a                       -> icodeN 34 UselessHiding a+    GenericUseless a b                    -> icodeN 35 GenericUseless a b+    RewriteAmbiguousRules a b c           -> icodeN 36 RewriteAmbiguousRules a b c+    RewriteMissingRule a b c              -> icodeN 37 RewriteMissingRule a b c+    ParseWarning a                        -> icodeN 38 ParseWarning a+    NoGuardednessFlag a                   -> icodeN 39 NoGuardednessFlag a -  value = vcase valu where-      valu [0, a, b]    = valuN UnreachableClauses a b-      valu [1, a, b]    = valuN OldBuiltin a b-      valu [2]          = valuN EmptyRewritePragma-      valu [3]          = valuN UselessPublic-      valu [4, a]       = valuN UselessInline a-      valu [5, a]       = valuN GenericWarning a-      valu [6, a, b, c] = valuN DeprecationWarning a b c-      valu [7, a]       = valuN NicifierIssue a-      valu [8, a]       = valuN InversionDepthReached a-      valu [9, a]       = valuN UserWarning a-      valu [10, a]      = valuN AbsurdPatternRequiresNoRHS a-      valu [11, a, b]   = valuN ModuleDoesntExport a b-      valu [12, a]      = valuN LibraryWarning a-      valu [13, a, b]   = valuN CoverageNoExactSplit a b-      valu [14, a]      = valuN CantGeneralizeOverSorts a-      valu [15, a]      = valuN IllformedAsClause a-      valu [16]         = valuN WithoutKFlagPrimEraseEquality-      valu [17, a]      = valuN InstanceWithExplicitArg a-      valu [18, a, b]   = valuN InfectiveImport a b-      valu [19, a, b]   = valuN CoInfectiveImport a b-      valu [20, a]      = valuN InstanceNoOutputTypeName a-      valu [21, a]      = valuN InstanceArgWithExplicitArg a-      valu [22]         = valuN WrongInstanceDeclaration-      valu [23, a, b, c, d] = valuN RewriteNonConfluent a b c d-      valu [24, a, b, c]    = valuN RewriteMaybeNonConfluent a b c-      valu [25, a, b]   = valuN PragmaCompileErased a b-      valu [26, a]      = valuN FixityInRenamingModule a-      valu [27, ns]     = valuN NotInScopeW ns-      valu [28, a, b]   = valuN ClashesViaRenaming a b-      valu _ = malformed+  value = vcase $ \ case+    [0, a, b]            -> valuN UnreachableClauses a b+    [1, a, b]            -> valuN OldBuiltin a b+    [2]                  -> valuN EmptyRewritePragma+    [3]                  -> valuN UselessPublic+    [4, a]               -> valuN UselessInline a+    [5, a]               -> valuN GenericWarning 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, a]              -> valuN AbsurdPatternRequiresNoRHS a+    [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, b]           -> valuN InfectiveImport a b+    [19, a, b]           -> valuN CoInfectiveImport a b+    [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, ns]             -> valuN NotInScopeW ns+    [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 GenericUseless 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, a]              -> valuN NoGuardednessFlag a+    _ -> malformed +instance EmbPrj ParseWarning where+  icod_ = \case+    OverlappingTokensWarning a -> icodeN 0 OverlappingTokensWarning a+    UnsupportedAttribute a b   -> icodeN 1 UnsupportedAttribute a b+    MultipleAttributes a b     -> icodeN 2 MultipleAttributes a b++  value = vcase $ \case+    [0, a]    -> valuN OverlappingTokensWarning a+    [1, a, b] -> valuN UnsupportedAttribute a b+    [2, a, b] -> valuN MultipleAttributes a b+    _ -> malformed++instance EmbPrj RecordFieldWarning where+  icod_ = \case+    DuplicateFieldsWarning a   -> icodeN 0 DuplicateFieldsWarning a+    TooManyFieldsWarning a b c -> icodeN 1 TooManyFieldsWarning a b c++  value = vcase $ \case+    [0, a]       -> valuN DuplicateFieldsWarning a+    [1, a, b, c] -> valuN TooManyFieldsWarning 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++instance EmbPrj DeclarationWarning' where   icod_ = \case     UnknownNamesInFixityDecl a        -> icodeN 0 UnknownNamesInFixityDecl a     UnknownNamesInPolarityPragmas a   -> icodeN 1 UnknownNamesInPolarityPragmas a@@ -137,6 +186,10 @@     InvalidCoverageCheckPragma r      -> icodeN 25 InvalidCoverageCheckPragma r     OpenPublicAbstract r              -> icodeN 26 OpenPublicAbstract r     OpenPublicPrivate r               -> icodeN 27 OpenPublicPrivate r+    EmptyConstructor a                -> icodeN 28 EmptyConstructor a+    InvalidRecordDirective a          -> icodeN 29 InvalidRecordDirective a+    InvalidConstructor a              -> icodeN 30 InvalidConstructor a+    InvalidConstructorBlock a         -> icodeN 31 InvalidConstructorBlock a    value = vcase $ \case     [0, a]   -> valuN UnknownNamesInFixityDecl a@@ -167,6 +220,10 @@     [25,r]   -> valuN InvalidCoverageCheckPragma r     [26,r]   -> valuN OpenPublicAbstract r     [27,r]   -> valuN OpenPublicPrivate r+    [28,r]   -> valuN EmptyConstructor r+    [29,r]   -> valuN InvalidRecordDirective r+    [30,r]   -> valuN InvalidConstructor r+    [31,r]   -> valuN InvalidConstructorBlock r     _ -> malformed  instance EmbPrj LibWarning where@@ -179,18 +236,30 @@  instance EmbPrj LibWarning' where   icod_ = \case-    UnknownField a -> icodeN 0 UnknownField a+    UnknownField     a   -> icodeN 0 UnknownField a+    ExeNotFound      a b -> icodeN 1 ExeNotFound a b+    ExeNotExecutable a b -> icodeN 2 ExeNotExecutable a b    value = vcase $ \case-    [0, a]   -> valuN UnknownField a+    [0, a]    -> valuN UnknownField a+    [1, a, b] -> valuN ExeNotFound a b+    [2, a, b] -> valuN ExeNotExecutable a b     _ -> malformed +instance EmbPrj ExecutablesFile where+  icod_ = \case+    ExecutablesFile a b -> icodeN 0 ExecutablesFile a b++  value = vcase $ \case+    [0, a, b] -> valuN ExecutablesFile a b+    _ -> malformed+ instance EmbPrj LibPositionInfo where   icod_ = \case     LibPositionInfo a b c -> icodeN 0 LibPositionInfo a b c    value = vcase $ \case-    [0, a, b, c]   -> valuN LibPositionInfo a b c+    [0, a, b, c] -> valuN LibPositionInfo a b c     _ -> malformed  instance EmbPrj Doc where@@ -200,13 +269,24 @@  instance EmbPrj PragmaOptions where   icod_ = \case-    PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ->-      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+    PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ->+      icodeN' PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc    value = vcase $ \case-    [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, ll, mm, nn, oo, pp, qq, rr, ss, tt, uu, vv] ->-      valuN PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv+    [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, ll, mm, nn, oo, pp, qq, rr, ss, tt, uu, vv, ww, xx, yy, zz, aaa, bbb, ccc] ->+      valuN PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc     _ -> malformed++instance EmbPrj UnicodeOrAscii++instance EmbPrj ConfluenceCheck where+  icod_ LocalConfluenceCheck  = icodeN' LocalConfluenceCheck+  icod_ GlobalConfluenceCheck = icodeN 0 GlobalConfluenceCheck++  value = vcase valu where+    valu []  = valuN LocalConfluenceCheck+    valu [0] = valuN GlobalConfluenceCheck+    valu _   = malformed  instance EmbPrj WarningMode where   icod_ = \case

src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs view

@@ -4,6 +4,7 @@  import qualified Agda.Interaction.Highlighting.Range   as HR import qualified Agda.Interaction.Highlighting.Precise as HP+import qualified Agda.Utils.RangeMap                   as RM  import Agda.TypeChecking.Serialise.Base import Agda.TypeChecking.Serialise.Instances.Common () --instance only@@ -53,6 +54,7 @@   icod_ HP.Pragma        = icodeN 6 ()   icod_ HP.Background    = icodeN 7 ()   icod_ HP.Markup        = icodeN 8 ()+  icod_ HP.Hole          = icodeN 9 ()    value = vcase valu where     valu [0]        = valuN HP.Comment@@ -65,10 +67,12 @@     valu [6]        = valuN HP.Pragma     valu [7]        = valuN HP.Background     valu [8]        = valuN HP.Markup+    valu [9]        = valuN HP.Hole     valu _          = malformed  instance EmbPrj HP.OtherAspect where   icod_ HP.Error                = icodeN 0 ()+  icod_ HP.ErrorWarning         = icodeN 1 ()   icod_ HP.DottedPattern        = icodeN' HP.DottedPattern   icod_ HP.UnsolvedMeta         = icodeN 2 ()   icod_ HP.TerminationProblem   = icodeN 3 ()@@ -85,6 +89,7 @@    value = vcase valu where     valu [0] = valuN HP.Error+    valu [1] = valuN HP.ErrorWarning     valu []  = valuN HP.DottedPattern     valu [2] = valuN HP.UnsolvedMeta     valu [3] = valuN HP.TerminationProblem@@ -110,10 +115,15 @@    value = valueN HP.DefinitionSite -instance EmbPrj HP.CompressedFile where-  icod_ (HP.CompressedFile f) = icodeN' HP.CompressedFile f+instance EmbPrj a => EmbPrj (RM.PairInt a) where+  icod_ (RM.PairInt a) = icodeN' RM.PairInt a -  value = valueN HP.CompressedFile+  value = valueN RM.PairInt++instance EmbPrj a => EmbPrj (RM.RangeMap a) where+  icod_ (RM.RangeMap f) = icodeN' RM.RangeMap f++  value = valueN RM.RangeMap  instance EmbPrj HP.TokenBased where   icod_ HP.TokenBased        = icodeN 0 ()

src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs view

@@ -65,8 +65,18 @@     valu [0, 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) = icodeN' ConHead a b c+  icod_ (ConHead a b c d) = icodeN' ConHead a b c d    value = valueN ConHead @@ -123,29 +133,26 @@    value = valueN Plus -instance EmbPrj LevelAtom where-  icod_ (NeutralLevel r a) = icodeN' (NeutralLevel r) a-  icod_ (UnreducedLevel a) = icodeN 1 UnreducedLevel a-  icod_ (MetaLevel a b)    = __IMPOSSIBLE__-  icod_ BlockedLevel{}     = __IMPOSSIBLE__+instance EmbPrj IsFibrant where+  icod_ IsFibrant = return 0+  icod_ IsStrict  = return 1 -  value = vcase valu where-    valu [a]    = valuN UnreducedLevel a -- we forget that we are a NeutralLevel,-                                         -- since we do not want do (de)serialize-                                         -- the reason for neutrality-    valu [1, a] = valuN UnreducedLevel a-    valu _      = malformed+  value 0 = return IsFibrant+  value 1 = return IsStrict+  value _ = malformed  instance EmbPrj I.Sort where   icod_ (Type  a  ) = icodeN 0 Type a   icod_ (Prop  a  ) = icodeN 1 Prop a   icod_ SizeUniv    = icodeN 2 SizeUniv-  icod_ Inf         = icodeN 3 Inf-  icod_ (PiSort a b) = icodeN 4 PiSort a b+  icod_ (Inf f a)   = icodeN 3 Inf f a+  icod_ (PiSort a b c) = icodeN 4 PiSort a b c   icod_ (FunSort a b) = icodeN 5 FunSort a b   icod_ (UnivSort a) = icodeN 6 UnivSort a   icod_ (MetaS a b)  = __IMPOSSIBLE__   icod_ (DefS a b)   = icodeN 7 DefS a b+  icod_ (SSet  a  ) = icodeN 8 SSet a+  icod_ LockUniv    = icodeN 9 LockUniv   icod_ (DummyS s)   = do     liftIO $ putStrLn $ "Dummy sort in serialization: " ++ s     __IMPOSSIBLE__@@ -154,11 +161,13 @@     valu [0, a]    = valuN Type  a     valu [1, a]    = valuN Prop  a     valu [2]       = valuN SizeUniv-    valu [3]       = valuN Inf-    valu [4, a, b] = valuN PiSort a b+    valu [3, f, a] = valuN Inf f a+    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 [8, a]    = valuN SSet a+    valu [9]       = valuN LockUniv     valu _         = malformed  instance EmbPrj DisplayForm where@@ -167,7 +176,7 @@   value = valueN Display  instance EmbPrj a => EmbPrj (Open a) where-  icod_ (OpenThing a b) = icodeN' OpenThing a b+  icod_ (OpenThing a b c d) = icodeN' OpenThing a b c d    value = valueN OpenThing @@ -251,18 +260,20 @@ instance EmbPrj NLPSort where   icod_ (PType a)   = icodeN 0 PType a   icod_ (PProp a)   = icodeN 1 PProp a-  icod_ PInf        = icodeN 2 PInf+  icod_ (PInf f a)  = icodeN 2 PInf f a   icod_ PSizeUniv   = icodeN 3 PSizeUniv+  icod_ PLockUniv   = icodeN 4 PSizeUniv    value = vcase valu where     valu [0, a] = valuN PType a     valu [1, a] = valuN PProp a-    valu [2]    = valuN PInf+    valu [2, f, a] = valuN PInf f a     valu [3]    = valuN PSizeUniv+    valu [4]    = valuN PLockUniv     valu _      = malformed  instance EmbPrj RewriteRule where-  icod_ (RewriteRule a b c d e f) = icodeN' RewriteRule a b c d e f+  icod_ (RewriteRule a b c d e f g) = icodeN' RewriteRule a b c d e f g    value = valueN RewriteRule @@ -282,7 +293,7 @@   value = valueN System  instance EmbPrj ExtLamInfo where-  icod_ (ExtLamInfo a b) = icodeN' ExtLamInfo a b+  icod_ (ExtLamInfo a b c) = icodeN' ExtLamInfo a b c    value = valueN ExtLamInfo @@ -316,11 +327,13 @@     valu _   = malformed  instance EmbPrj DoGeneralize where-  icod_ YesGeneralize = return 0-  icod_ NoGeneralize  = return 1+  icod_ YesGeneralizeVar  = return 0+  icod_ YesGeneralizeMeta = return 1+  icod_ NoGeneralize      = return 2 -  value 0 = return YesGeneralize-  value 1 = return NoGeneralize+  value 0 = return YesGeneralizeVar+  value 1 = return YesGeneralizeMeta+  value 2 = return NoGeneralize   value _ = malformed  instance EmbPrj Occurrence where@@ -349,26 +362,28 @@     valu _     = malformed  instance EmbPrj Defn where-  icod_ Axiom                                           = icodeN 0 Axiom+  icod_ (Axiom       a)                                 = icodeN 0 Axiom a   icod_ (Function    a b s t (_:_) c d e f g h i j k)   = __IMPOSSIBLE__   icod_ (Function    a b s t []    c d e f g h i j k)   =     icodeN 1 (\ a b s -> Function a b s t []) a b s c d e f g h i j k   icod_ (Datatype    a b c d e f g h)                   = icodeN 2 Datatype a b c d e f g h-  icod_ (Record      a b c d e f g h i j k)             = icodeN 3 Record 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)           = icodeN 3 Record a b c d e f g h i j k l   icod_ (Constructor a b c d e f g h i j)               = icodeN 4 Constructor a b c d e f g h i j   icod_ (Primitive   a b c d e)                         = icodeN 5 Primitive a b c d e+  icod_ (PrimitiveSort a b)                             = icodeN 6 PrimitiveSort a b   icod_ AbstractDefn{}                                  = __IMPOSSIBLE__-  icod_ GeneralizableVar                                = icodeN 6 GeneralizableVar+  icod_ GeneralizableVar                                = icodeN 7 GeneralizableVar   icod_ DataOrRecSig{}                                  = __IMPOSSIBLE__    value = vcase valu where-    valu [0]                                        = valuN Axiom+    valu [0, a]                                     = valuN Axiom a     valu [1, a, b, s, c, d, e, f, g, h, i, j, k]    = valuN (\ a b s -> Function a b s Nothing []) a b s c d e f g h i j k     valu [2, a, b, c, d, e, f, g, h]                = valuN Datatype a b c d e f g h-    valu [3, a, b, c, d, e, f, g, h, i, j, k]       = valuN Record  a b c d e f g h i j k+    valu [3, a, b, c, d, e, f, g, h, i, j, k, l]    = valuN Record  a b c d e f g h i j k l     valu [4, a, b, c, d, e, f, g, h, i, j]          = valuN Constructor a b c d e f g h i j     valu [5, a, b, c, d, e]                         = valuN Primitive   a b c d e-    valu [6]                                        = valuN GeneralizableVar+    valu [6, a, b]                                  = valuN PrimitiveSort a b+    valu [7]                                        = valuN GeneralizableVar     valu _                                          = malformed  instance EmbPrj LazySplit where@@ -422,12 +437,12 @@   value = valueN Branches  instance EmbPrj CompiledClauses where-  icod_ Fail       = icodeN' Fail+  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    value = vcase valu where-    valu []        = valuN Fail+    valu [a]       = valuN Fail a     valu [a, b]    = valuN Done a b     valu [2, a, b] = valuN Case a b     valu _         = malformed@@ -457,7 +472,7 @@     valu _      = malformed  instance EmbPrj I.Clause where-  icod_ (Clause a b c d e f g h i j) = icodeN' Clause a b c d e f g h i j+  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    value = valueN Clause

src/full/Agda/TypeChecking/SizedTypes.hs view

@@ -4,34 +4,37 @@  import Prelude hiding (null) +import Control.Monad.Except import Control.Monad.Writer  import qualified Data.Foldable as Fold import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Pretty.Constraint import Agda.TypeChecking.Reduce-import {-# SOURCE #-} Agda.TypeChecking.MetaVars import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import {-# SOURCE #-} Agda.TypeChecking.MetaVars+import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (MonadCheckInternal, infer) import {-# SOURCE #-} Agda.TypeChecking.Conversion import {-# SOURCE #-} Agda.TypeChecking.Constraints -import Agda.Utils.Except ( MonadError(catchError, throwError) ) import Agda.Utils.Functor import Agda.Utils.List as List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (Pretty)+import Agda.Utils.Pretty (Pretty, prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple@@ -56,14 +59,14 @@         "in context " <+> inTopContext (prettyTCM tel)       ]   reportSLn "tc.size" 60 $ "- raw type = " ++ show t-  let postpone :: Term -> TCM ()-      postpone t = do+  let postpone :: Blocker -> Term -> TCM ()+      postpone b t = do         reportSDoc "tc.size.lt" 20 $ sep           [ "- postponing `not empty type of sizes' check for " <+> prettyTCM t ]-        addConstraint $ CheckSizeLtSat t+        addConstraint b $ CheckSizeLtSat t   let ok :: TCM ()       ok = reportSLn "tc.size.lt" 20 $ "- succeeded: not an empty type of sizes"-  ifBlocked t (const postpone) $ \ _ t -> do+  ifBlocked t postpone $ \ _ t -> do     reportSLn "tc.size.lt" 20 $ "- type is not blocked"     caseMaybeM (isSizeType t) ok $ \ b -> do       reportSLn "tc.size.lt" 20 $ " - type is a size type"@@ -71,7 +74,7 @@         BoundedNo -> ok         BoundedLt b -> do           reportSDoc "tc.size.lt" 20 $ " - type is SIZELT" <+> prettyTCM b-          ifBlocked b (\ _ _ -> postpone t) $ \ _ b -> do+          ifBlocked b (\ x _ -> postpone x t) $ \ _ b -> do             reportSLn "tc.size.lt" 20 $ " - size bound is not blocked"             catchConstraint (CheckSizeLtSat t) $ do               unlessM (checkSizeNeverZero b) $ do@@ -138,13 +141,16 @@   ts <- map (snd . unDom) . take i <$> getContext   -- If we encountered a blocking meta in the context, we cannot   -- say ``no'' for sure.-  (n, Any meta) <- runWriterT $ minSizeValAux ts $ repeat 0+  (n, blockers) <- runWriterT $ minSizeValAux ts $ repeat 0+  let blocker = unblockOnAll blockers   if n > 0 then return True else-    if meta then patternViolation else return False+    if blocker == alwaysUnblock+      then return False+      else patternViolation blocker   where   -- Compute the least valuation for size context ts above the   -- given valuation and return its last value.-  minSizeValAux :: [Type] -> [Int] -> WriterT Any TCM Int+  minSizeValAux :: [Type] -> [Int] -> WriterT (Set Blocker) TCM Int   minSizeValAux _        []      = __IMPOSSIBLE__   minSizeValAux []       (n : _) = return n   minSizeValAux (t : ts) (n : ns) = do@@ -153,42 +159,48 @@              " 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-        perhaps = tell (Any True) >> cont+        perhaps x = tell (Set.singleton x) >> cont     -- If we encounter a blocked type in the context, we cannot     -- give a definite answer.-    ifBlocked t (\ _ _ -> perhaps) $ \ _ t -> do+    ifBlocked t (\ x _ -> perhaps x) $ \ _ t -> do       caseMaybeM (liftTCM $ isSizeType t) cont $ \ b -> do         case b of           BoundedNo -> cont-          BoundedLt u -> ifBlocked u (\ _ _ -> perhaps) $ \ _ u -> do+          BoundedLt u -> ifBlocked u (\ x _ -> perhaps x) $ \ _ u -> do             reportSLn "tc.size" 60 $ "minSizeVal upper bound u = " ++ show u             v <- liftTCM $ deepSizeView u             case v of               -- Variable 0 has bound @(< j + m)@               -- meaning that @minval(j) > n - m@, i.e., @minval(j) >= n+1-m@.               -- Thus, we update the min value for @j@ with function @(max (n+1-m))@.-              DSizeVar j m -> do+              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')                 minSizeValAux ts ns'-              DSizeMeta{} -> perhaps+              DSizeMeta x _ _ -> perhaps (unblockOnMeta x)               _ -> cont  -- | Check whether a variable in the context is bounded by a size expression. --   If @x : Size< a@, then @a@ is returned.-isBounded :: (MonadReduce m, MonadTCEnv m, HasBuiltins m)-          => Nat -> m BoundedSize-isBounded i = do-  t <- reduce =<< typeOfBV i-  case unEl t of+isBounded :: PureTCM m => Nat -> m BoundedSize+isBounded i = isBoundedSizeType =<< typeOfBV i++isBoundedProjVar+  :: (MonadCheckInternal m, PureTCM m)+  => ProjectedVar -> m BoundedSize+isBoundedProjVar pv = isBoundedSizeType =<< infer (unviewProjectedVar pv)++isBoundedSizeType :: PureTCM m => Type -> m BoundedSize+isBoundedSizeType t =+  reduce (unEl t) >>= \case     Def x [Apply u] -> do       sizelt <- getBuiltin' builtinSizeLt       return $ if (Just (Def x []) == sizelt) then BoundedLt $ unArg u else BoundedNo     _ -> return BoundedNo  -- | Whenever we create a bounded size meta, add a constraint---   expressing the bound.+--   expressing the bound. First argument is the new meta and must be a @MetaV{}@. --   In @boundedSizeMetaHook v tel a@, @tel@ includes the current context. boundedSizeMetaHook   :: ( MonadConstraint m@@ -199,7 +211,7 @@      , HasBuiltins m      )   => Term -> Telescope -> Type -> m ()-boundedSizeMetaHook v tel0 a = do+boundedSizeMetaHook v@(MetaV x _) tel0 a = do   res <- isSizeType a   case res of     Just (BoundedLt u) -> do@@ -209,8 +221,9 @@       addContext tel $ do         v <- sizeSuc 1 $ raise (size tel) v `apply` teleArgs tel         -- compareSizes CmpLeq v u-        addConstraint $ ValueCmp CmpLeq AsSizes v u+        addConstraint (unblockOnMeta x) $ ValueCmp CmpLeq AsSizes v u     _ -> return ()+boundedSizeMetaHook _ _ _ = __IMPOSSIBLE__  -- | @trySizeUniv cmp t m n x els1 y els2@ --   is called as a last resort when conversion checking @m `cmp` n : t@@@ -226,7 +239,8 @@   => Comparison -> CompareAs -> Term -> Term   -> QName -> Elims -> QName -> Elims -> m () trySizeUniv cmp t m n x els1 y els2 = do-  let failure = typeError $ UnequalTerms cmp m n t+  let failure :: forall m a. MonadTCError m => m a+      failure = typeError $ UnequalTerms cmp m n t       forceInfty u = compareSizes CmpEq (unArg u) =<< primSizeInf   -- Get the SIZE built-ins.   (size, sizelt) <- flip catchError (const failure) $ do@@ -249,21 +263,22 @@  -- | Compute the deep size view of a term. --   Precondition: sized types are enabled.-deepSizeView :: Term -> TCM DeepSizeView+deepSizeView :: (PureTCM m, MonadTCError m) => Term -> m DeepSizeView deepSizeView v = do   Def inf [] <- primSizeInf   Def suc [] <- primSizeSuc-  let loop v = do-        v <- reduce v-        case v of+  let loop v =+        reduce v >>= \case           Def x []        | x == inf -> return $ DSizeInf           Def x [Apply u] | x == suc -> sizeViewSuc_ suc <$> loop (unArg u)-          Var i []                   -> return $ DSizeVar i 0++          Var i es | Just pv <- ProjectedVar i <$> mapM isProjElim es+                                     -> return $ DSizeVar pv 0           MetaV x us                 -> return $ DSizeMeta x us 0-          _                          -> return $ DOtherSize v+          v                          -> return $ DOtherSize v   loop v -sizeMaxView :: (MonadReduce m, HasBuiltins m) => Term -> m SizeMaxView+sizeMaxView :: PureTCM m => Term -> m SizeMaxView sizeMaxView v = do   inf <- getBuiltinDefName builtinSizeInf   suc <- getBuiltinDefName builtinSizeSuc@@ -274,7 +289,8 @@           Def x []                   | Just x == inf -> return $ singleton $ DSizeInf           Def x [Apply u]            | Just x == suc -> maxViewSuc_ (fromJust suc) <$> loop (unArg u)           Def x [Apply u1, Apply u2] | Just x == max -> maxViewMax <$> loop (unArg u1) <*> loop (unArg u2)-          Var i []                      -> return $ singleton $ DSizeVar i 0+          Var i es | Just pv <- ProjectedVar i <$> mapM isProjElim es+                                        -> return $ singleton $ DSizeVar pv 0           MetaV x us                    -> return $ singleton $ DSizeMeta x us 0           _                             -> return $ singleton $ DOtherSize v   loop v@@ -360,7 +376,7 @@     (_    ,  DSizeInf,     _         ) -> continue CmpEq     (CmpLeq, DSizeVar i n, DSizeVar j m) | i == j -> unless (n <= m) failure     (CmpLeq, DSizeVar i n, DSizeVar j m) | i /= j -> do-       res <- isBounded i+       res <- isBoundedProjVar i        case res of          BoundedNo -> failure          BoundedLt u' -> do@@ -380,8 +396,10 @@ giveUp :: (MonadConversion m) => Comparison -> Type -> Term -> Term -> m () giveUp cmp size u v =   ifM (asksTC envAssignMetas)-    {-then-} (addConstraint $ ValueCmp CmpLeq AsSizes u v)+    {-then-} (addConstraint unblock $ ValueCmp CmpLeq AsSizes u v)     {-else-} (typeError $ UnequalTerms cmp u v AsSizes)+  where+    unblock = unblockOnAnyMetaIn [u, v]  -- | Checked whether a size constraint is trivial (like @X <= X+1@). trivial :: (MonadConversion m) => Term -> Term -> m Bool@@ -426,16 +444,16 @@ isSizeConstraint_ _isSizeType _ _ = False  -- | Take out all size constraints of the given direction (DANGER!).-takeSizeConstraints :: (Comparison -> Bool) -> TCM [Closure Constraint]+takeSizeConstraints :: (Comparison -> Bool) -> TCM [ProblemConstraint] takeSizeConstraints p = do   test <- isSizeTypeTest-  map theConstraint <$> takeConstraints (mkIsSizeConstraint test p . theConstraint)+  takeConstraints (mkIsSizeConstraint test p . theConstraint)  -- | Find the size constraints of the matching direction.-getSizeConstraints :: (Comparison -> Bool) -> TCM [Closure Constraint]+getSizeConstraints :: (Comparison -> Bool) -> TCM [ProblemConstraint] getSizeConstraints p = do   test <- isSizeTypeTest-  filter (mkIsSizeConstraint test p) . map theConstraint <$> getAllConstraints+  filter (mkIsSizeConstraint test p . theConstraint) <$> getAllConstraints  -- | Return a list of size metas and their context. getSizeMetas :: Bool -> TCM [(MetaId, Type, Telescope)]@@ -519,13 +537,13 @@ --   contexts. -- --   cf. 'Agda.TypeChecking.LevelConstraints.simplifyLevelConstraint'-oldComputeSizeConstraints :: [Closure Constraint] -> TCM [OldSizeConstraint]+oldComputeSizeConstraints :: [ProblemConstraint] -> TCM [OldSizeConstraint] oldComputeSizeConstraints [] = return [] -- special case to avoid maximum [] oldComputeSizeConstraints cs = catMaybes <$> mapM oldComputeSizeConstraint leqs   where     -- get the constraints plus contexts they are defined in-    gammas       = map (envContext . clEnv) cs-    ls           = map clValue cs+    gammas       = map (envContext . clEnv . theConstraint) cs+    ls           = map (clValue . theConstraint) cs     -- compute the longest context (common water level)     ns           = map size gammas     waterLevel   = maximum ns@@ -554,21 +572,20 @@ -- | 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 :: (MonadReduce m, MonadDebug m, MonadError TCErr m, HasBuiltins m)-            => Term -> m (OldSizeExpr, Int)+oldSizeExpr :: (PureTCM m, MonadBlock m) => Term -> m (OldSizeExpr, Int) oldSizeExpr u = do   u <- reduce u -- Andreas, 2009-02-09.                 -- This is necessary to surface the solutions of metavariables.   reportSDoc "tc.conv.size" 60 $ "oldSizeExpr:" <+> prettyTCM u   s <- sizeView u   case s of-    SizeInf     -> patternViolation+    SizeInf     -> patternViolation neverUnblock     SizeSuc u   -> mapSnd (+1) <$> oldSizeExpr u     OtherSize u -> case u of       Var i []  -> return (Rigid i, 0)       MetaV m es | Just xs <- mapM isVar es, fastDistinct xs                 -> return (SizeMeta m xs, 0)-      _ -> patternViolation+      _ -> patternViolation neverUnblock   where     isVar (Proj{})  = Nothing     isVar (IApply _ _ v) = isVar (Apply (defaultArg v))@@ -597,17 +614,17 @@   case (a,b) of     (Rigid{}, Rigid{})       -> return c     (SizeMeta m xs, Rigid i) -> do-      j <- List.findIndex (==i) xs+      j <- List.elemIndex i xs       return $ Leq (SizeMeta m [0..size xs-1]) n (Rigid j)     (Rigid i, SizeMeta m xs) -> do-      j <- List.findIndex (==i) xs+      j <- List.elemIndex i xs       return $ Leq (Rigid j) n (SizeMeta m [0..size xs-1])     (SizeMeta m xs, SizeMeta l ys)          -- try to invert xs on ys-       | Just ys' <- mapM (\ y -> List.findIndex (==y) xs) ys ->+       | Just ys' <- mapM (\ y -> List.elemIndex y xs) ys ->            return $ Leq (SizeMeta m [0..size xs-1]) n (SizeMeta l ys')          -- try to invert ys on xs-       | Just xs' <- mapM (\ x -> List.findIndex (==x) ys) xs ->+       | Just xs' <- mapM (\ x -> List.elemIndex x ys) xs ->            return $ Leq (SizeMeta m xs') n (SizeMeta l [0..size ys-1])          -- give up        | otherwise -> Nothing@@ -665,7 +682,7 @@     -- have been solved correctly.     flip catchError (const cannotSolve) $       noConstraints $-        forM_ cs0 $ \ cl -> enterClosure cl solveConstraint+        forM_ cs0 $ withConstraint solveConstraint   -- | Old solver for size constraints using "Agda.Utils.Warshall".@@ -685,7 +702,7 @@   case W.solve $ map mkFlex metas ++ map mkConstr cs of     Nothing  -> cannotSolve     Just sol -> do-      reportSLn "tc.size.solve" 10 $ "Solved constraints: " ++ show sol+      reportSLn "tc.size.solve" 10 $ "Solved constraints: " ++ prettyShow sol       suc   <- primSizeSuc       infty <- primSizeInf       let plus v 0 = v

src/full/Agda/TypeChecking/SizedTypes/Solve.hs view

@@ -51,15 +51,14 @@ import Prelude hiding (null)  import Control.Monad hiding (forM, forM_)+import Control.Monad.Except import Control.Monad.Trans.Maybe  import Data.Either-import Data.Foldable (foldMap, forM_)+import Data.Foldable (forM_) import qualified Data.Foldable as Fold import Data.Function import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..), nonEmpty)-import qualified Data.List.NonEmpty as NonEmpty import Data.Monoid import qualified Data.Map as Map import Data.Set (Set)@@ -71,7 +70,6 @@ import Agda.Syntax.Internal.MetaVars  import Agda.TypeChecking.Monad as TCM hiding (Offset)-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Free import Agda.TypeChecking.Reduce@@ -86,13 +84,12 @@ import Agda.TypeChecking.SizedTypes.WarshallSolver as Size  import Agda.Utils.Cluster-import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens-+import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, (<|)) import qualified Agda.Utils.List as List-+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -104,7 +101,7 @@  import Agda.Utils.Impossible -type CC = Closure TCM.Constraint+type CC = ProblemConstraint  -- | Flag to control the behavior of size solver. data DefaultToInfty@@ -119,14 +116,14 @@    -- 1. Take out the size constraints normalised. -  cs0 <- mapM (mapClosure normalise) =<< S.takeSizeConstraints (== CmpLeq)+  let norm c = mapClosure normalise (theConstraint c) <&> \ cl -> c { theConstraint = cl }+  cs0 <- mapM norm =<< S.takeSizeConstraints (== CmpLeq)     -- NOTE: this deletes the size constraints from the constraint set!   unless (null cs0) $     reportSDoc "tc.size.solve" 40 $ vcat $-      [ text $ "Solving constraints (" ++ show flag ++ ")"-      ] ++ map prettyTCM cs0+      text ( "Solving constraints (" ++ show flag ++ ")" ) : map prettyTCM cs0   let -- Error for giving up-      cannotSolve :: TCM a+      cannotSolve :: TCM a -- Defined, but not currently used       cannotSolve = typeError . GenericDocError =<<         vcat ("Cannot solve size constraints" : map prettyTCM cs0) @@ -136,7 +133,7 @@   sizeMetaSet <- Set.fromList . map (\ (x, _t, _tel) -> x) <$> S.getSizeMetas True    -- Pair each constraint with its list of size metas occurring in it.-  cms <- forM cs0 $ \ cl -> enterClosure cl $ \ c -> do+  cms <- forM cs0 $ \ cl -> enterClosure (theConstraint cl) $ \ c -> do      -- @allMetas@ does not reduce or instantiate;     -- this is why we require the size constraints to be normalised.@@ -144,7 +141,7 @@       sizeMetaSet `Set.intersection` allMetas singleton c)    -- Now, some constraints may have no metas (clcs), the others have at least one (othercs).-  let classify :: (a, [b]) -> Either a (a, NonEmpty b)+  let classify :: (a, [b]) -> Either a (a, List1 b)       classify (cl, [])     = Left  cl       classify (cl, (x:xs)) = Right (cl, x :| xs)   let (clcs, othercs) = partitionEithers $ map classify cms@@ -161,29 +158,27 @@   -- Solve the clusters.    constrainedMetas <- Set.unions <$> do-    forM  (ccs) $ \ (cs :: NonEmpty CC) -> do+    forM  (ccs) $ \ (cs :: List1 CC) -> do -      reportSDoc "tc.size.solve" 60 $ vcat $ concat-        [ [ "size constraint cluster:" ]-        , map (text . show) $ NonEmpty.toList cs-        ]+      reportSDoc "tc.size.solve" 60 $ vcat $+        "size constraint cluster:" <| fmap (text . show) cs        -- Convert each constraint in the cluster to the largest context.       -- (Keep fingers crossed). -      enterClosure (Fold.maximumBy (compare `on` (length . envContext . clEnv)) cs) $ \ _ -> do+      enterClosure (Fold.maximumBy (compare `on` (length . envContext . clEnv)) $ fmap theConstraint cs) $ \ _ -> do         -- Get all constraints that can be cast to the longest context.-        cs' :: [TCM.Constraint] <- catMaybes <$> do-          mapM (runMaybeT . castConstraintToCurrentContext) $ NonEmpty.toList cs+        cs' :: [ProblemConstraint] <- List1.catMaybes <$> do+          mapM (runMaybeT . castConstraintToCurrentContext) cs          reportSDoc "tc.size.solve" 20 $ vcat $-          [ "converted size constraints to context: " <+> do+          ( "converted size constraints to context: " <+> do               tel <- getContextTelescope               inTopContext $ prettyTCM tel-          ] ++ map (nest 2 . prettyTCM) cs'+          ) : map (nest 2 . prettyTCM) cs'          -- Solve the converted constraints.-        solveSizeConstraints_ flag =<<  mapM buildClosure cs'+        solveSizeConstraints_ flag cs'    -- 4. Possibly set remaining metas to infinity. @@ -215,7 +210,7 @@   -- 5. Make sure we did not lose any constraints.    -- This is necessary since we have removed the size constraints.-  forM_ cs0 $ \ cl -> enterClosure cl solveConstraint+  forM_ cs0 $ withConstraint solveConstraint   -- | TODO: this does not actually work!@@ -319,10 +314,11 @@ -- --   This hack lets issue 2046 go through. -castConstraintToCurrentContext :: Closure TCM.Constraint -> MaybeT TCM TCM.Constraint-castConstraintToCurrentContext cl = do+castConstraintToCurrentContext :: ProblemConstraint -> MaybeT TCM ProblemConstraint+castConstraintToCurrentContext c = do   -- The checkpoint of the contraint-  let cp = envCurrentCheckpoint $ clEnv cl+  let cl = theConstraint c+      cp = envCurrentCheckpoint $ clEnv cl   sigma <- caseMaybeM (viewTC $ eCheckpoints . key cp)           (do             -- We are not in a descendant of the constraint checkpoint.@@ -346,7 +342,8 @@             return $ parallelS $ map (maybe __DUMMY_TERM__ var) cand           ) return -- Phew, we've got the checkpoint! All is well.   -- Apply substitution to constraint and pray that the Gods are merciful on us.-  return $ applySubst sigma (clValue cl)+  cl' <- buildClosure $ applySubst sigma (clValue cl)+  return $ c { theConstraint = cl' }   -- Note: the resulting constraint may not well-typed.   -- Even if it is, it may map variables to their wrong counterpart. @@ -373,7 +370,7 @@   let (csNoM, csMs) = (`List.partitionMaybe` ccs') $ \ p@(c0, c) ->         fmap (p,) $ nonEmpty $ map (metaId . sizeMetaId) $ Set.toList $ flexs c   -- @css@ are the clusters of constraints.-      css :: [NonEmpty (CC,HypSizeConstraint)]+      css :: [List1 (CC,HypSizeConstraint)]       css = cluster' csMs    -- Check that the closed constraints are valid.@@ -386,16 +383,16 @@  -- | Solve a cluster of constraints sharing some metas. ---solveCluster :: DefaultToInfty -> NonEmpty (CC,HypSizeConstraint) -> TCM ()+solveCluster :: DefaultToInfty -> List1 (CC, HypSizeConstraint) -> TCM () solveCluster flag ccs = do   let cs = fmap snd ccs-  let prettyCs   = map prettyTCM $ NonEmpty.toList cs+  let prettyCs   = map prettyTCM $ List1.toList cs   let err reason = typeError . GenericDocError =<< do         vcat $           [ text $ "Cannot solve size constraints" ] ++ prettyCs ++           [ text $ "Reason: " ++ reason ]   reportSDoc "tc.size.solve" 20 $ vcat $-    [ "Solving constraint cluster" ] ++ prettyCs+    "Solving constraint cluster" : prettyCs   -- Find the super context of all contexts. {-   -- We use the @'ctxId'@s.@@ -427,7 +424,7 @@   -- Canonicalize the constraints.   -- This is unsound in the presence of hypotheses.       csC :: [SizeConstraint]-      csC = applyWhen (null hs) (mapMaybe canonicalizeSizeConstraint) $ NonEmpty.toList csL+      csC = applyWhen (null hs) (mapMaybe canonicalizeSizeConstraint) $ List1.toList csL   reportSDoc "tc.size.solve" 30 $ vcat $     [ "Size hypotheses" ] ++     map (prettyTCM . HypSizeConstraint gamma hids hs) hs ++@@ -467,7 +464,7 @@    -- Convert size metas to flexible vars.   let metas :: [SizeMeta]-      metas = concat $ map (foldMap (:[])) csC+      metas = concatMap (foldMap (:[])) csC       csF   :: [Size.Constraint' NamedRigid Int]       csF   = map (fmap (metaId . sizeMetaId)) csC @@ -530,10 +527,10 @@   --  ms = unsolved size metas from cluster   let ms = Set.fromList (map sizeMetaId metas) Set.\\ solved   --  Make sure they do not contain an interaction point-  let noIP = Set.null $ Set.intersection ims ms+  let noIP = Set.disjoint ims ms    unless (null ms) $ reportSDoc "tc.size.solve" 30 $ fsep $-    [ "cluster did not solve these size metas: " ] ++ map prettyTCM (Set.toList ms)+    "cluster did not solve these size metas: " : map prettyTCM (Set.toList ms)    solvedAll <- do     -- If no metas are left, we have solved this cluster completely.@@ -563,13 +560,13 @@    -- Double check.   when solvedAll $ do-    let cs0 = map fst $ NonEmpty.toList ccs+    let cs0 = fmap fst ccs         -- Error for giving up         cannotSolve = typeError . GenericDocError =<<-          vcat ("Cannot solve size constraints" : map prettyTCM cs0)+          vcat ("Cannot solve size constraints" <| fmap prettyTCM cs0)     flip catchError (const cannotSolve) $       noConstraints $-        forM_ cs0 $ \ cl -> enterClosure cl solveConstraint+        forM_ cs0 $ withConstraint solveConstraint  -- | Collect constraints from a typing context, looking for SIZELT hypotheses. getSizeHypotheses :: Context -> TCM [(Nat, SizeConstraint)]@@ -682,7 +679,8 @@ instance PrettyTCM SizeMeta where   prettyTCM (SizeMeta x es) = prettyTCM (MetaV x $ map (Apply . defaultArg . var) es) -instance Subst Term SizeMeta where+instance Subst SizeMeta where+  type SubstArg SizeMeta = Term   applySubst sigma (SizeMeta x es) = SizeMeta x (map raise es)     where       raise i =@@ -698,7 +696,8 @@ -- deriving instance Traversable (SizeExpr' Int)  -- | Only for 'raise'.-instance Subst Term (SizeExpr' NamedRigid SizeMeta) where+instance Subst (SizeExpr' NamedRigid SizeMeta) where+  type SubstArg (SizeExpr' NamedRigid SizeMeta) = Term   applySubst sigma a =     case a of       Infty   -> a@@ -711,7 +710,8 @@  type SizeConstraint = Constraint' NamedRigid SizeMeta -instance Subst Term SizeConstraint where+instance Subst SizeConstraint where+  type SubstArg SizeConstraint = Term   applySubst sigma (Constraint a cmp b) =     Constraint (applySubst sigma a) cmp (applySubst sigma b) @@ -730,7 +730,8 @@   , sizeConstraint :: SizeConstraint    -- ^ Living in @Context@.   } -instance Flexs SizeMeta HypSizeConstraint where+instance Flexs HypSizeConstraint where+  type FlexOf HypSizeConstraint = SizeMeta   flexs (HypSizeConstraint _ _ hs c) = flexs hs `mappend` flexs c  instance PrettyTCM HypSizeConstraint where@@ -740,15 +741,15 @@       -- text ("[#cxt=" ++ show (size cxt) ++ "]") <+> do       prettyList (map prettyTCM cxtNames) <+> do       applyUnless (null hs)-       (((hcat $ punctuate ", " $ map prettyTCM hs) <+> "|-") <+>)+       ((hcat (punctuate ", " $ map prettyTCM hs) <+> "|-") <+>)        (prettyTCM c)  -- | Turn a constraint over de Bruijn indices into a size constraint.-computeSizeConstraint :: Closure TCM.Constraint -> TCM (Maybe HypSizeConstraint)+computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint) computeSizeConstraint c = do-  let cxt = envContext $ clEnv c+  let cxt = envContext $ clEnv $ theConstraint c   unsafeModifyContext (const cxt) $ do-    case clValue c of+    case clValue $ theConstraint c of       ValueCmp CmpLeq _ u v -> do         reportSDoc "tc.size.solve" 50 $ sep $           [ "converting size constraint"

src/full/Agda/TypeChecking/SizedTypes/Syntax.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE UndecidableInstances       #-}  -- | Syntax of size expressions and constraints. @@ -9,12 +6,10 @@ import Prelude hiding ( null )  -import Data.Foldable (Foldable) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Traversable (Traversable)  import Agda.TypeChecking.SizedTypes.Utils @@ -28,7 +23,7 @@ newtype Offset = O Int   deriving (Eq, Ord, Num, Enum) --- This Show instance is ok because of the Enum constraint.+-- This Show instance is ok because of the Num constraint. instance Show Offset where   show (O n) = show n @@ -296,29 +291,38 @@ -- * Computing variable sets  -- | The rigid variables contained in a pice of syntax.-class Rigids r a where-  rigids :: a -> Set r+class Ord (RigidOf a) => Rigids a where+  type RigidOf a+  rigids :: a -> Set (RigidOf a) -instance (Ord r, Rigids r a) => Rigids r [a] where+instance Rigids a => Rigids [a] where+  type RigidOf [a] = RigidOf a   rigids as = Set.unions (map rigids as) -instance Rigids r (SizeExpr' r f) where+instance Ord r => Rigids (SizeExpr' r f) where+  type RigidOf (SizeExpr' r f) = r   rigids (Rigid x _) = Set.singleton x+   rigids _           = Set.empty -instance Ord r => Rigids r (Constraint' r f) where+instance Ord r => Rigids (Constraint' r f) where+  type RigidOf (Constraint' r f) = r   rigids (Constraint l _ r) = Set.union (rigids l) (rigids r)  -- | The flexibe variables contained in a pice of syntax.-class Flexs flex a | a -> flex where-  flexs :: a -> Set flex+class Ord (FlexOf a) => Flexs a where+  type FlexOf a+  flexs :: a -> Set (FlexOf a) -instance (Ord flex, Flexs flex a) => Flexs flex [a] where+instance Flexs a => Flexs [a] where+  type FlexOf [a] = FlexOf a   flexs as = Set.unions (map flexs as) -instance Flexs flex (SizeExpr' rigid flex) where+instance Ord flex => Flexs (SizeExpr' rigid flex) where+  type FlexOf (SizeExpr' rigid flex) = flex   flexs (Flex x _) = Set.singleton x   flexs _          = Set.empty -instance (Ord flex) => Flexs flex (Constraint' rigid flex) where+instance Ord flex => Flexs (Constraint' rigid flex) where+  type FlexOf (Constraint' rigid flex) = flex   flexs (Constraint l _ r) = Set.union (flexs l) (flexs r)

src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE NoMonomorphismRestriction #-}  module Agda.TypeChecking.SizedTypes.WarshallSolver where @@ -267,9 +266,6 @@ instance Negative a => Negative (Edge' r f a) where   negative = negative . label --- instance Show a => Show (Edge' a) where---   show (Edge u v l) = show u ++ " -(" ++ show l ++ ")-> " ++ show v- instance (Ord r, Ord f, MeetSemiLattice a) => MeetSemiLattice (Edge' r f a) where   e@(Edge u v l) `meet` e'@(Edge u' v' l')     | u == u' && v == v' = Edge u v $ l `meet` l'@@ -348,10 +344,10 @@ implies :: (Ord r, Ord f, Pretty r, Pretty f, Pretty a, Top a, Ord a, Negative a)   => Graph r f a -> Graph r f a -> Bool -- iterate 'test' over all edges in g-implies h g = and $ map test $ graphToList g-  -- NB: doing the @test k l@ before the recursive @b@ gives-  -- opportunity to short-cut the conjunction @&&@.+implies h g = all test (graphToList g)   where+    -- NB: doing the @test k l@ before the recursive @b@ gives+    -- opportunity to short-cut the conjunction @&&@.     -- test :: Key -> a -> Bool     test k@(Edge src dest l)       | isZeroNode src, not (negative l) = True@@ -361,9 +357,15 @@       | isTop l                          = True       | otherwise = case lookupEdge h src dest of         Nothing -> False-        Just l' -> if l' <= l then True else-          trace ("edge " ++ prettyShow (l <$ k) ++ " not implied by " ++ prettyShow (l' <$ k)) $-            False+        Just l' ->+          (l' <= l) || ( trace+                           ( "edge " ++ prettyShow (l <$ k)+                               ++ " not implied by "+                               ++ prettyShow (l' <$ k)+                           )+                           $ False+                       )+ -- implies h g = Map.foldlWithKey (\ b k l -> test k l && b) True g --   -- NB: doing the @test k l@ before the recursive @b@ gives --   -- opportunity to short-cut the conjunction @&&@.@@ -382,7 +384,7 @@ --             False  nodeFromSizeExpr :: SizeExpr' rigid flex -> (Node rigid flex, Offset)-nodeFromSizeExpr e = case e of+nodeFromSizeExpr = \case   Const   n -> (NodeZero   , n)   Rigid i n -> (NodeRigid i, n)   Flex  x n -> (NodeFlex x , n)

src/full/Agda/TypeChecking/Sort.hs view

@@ -22,6 +22,7 @@ module Agda.TypeChecking.Sort where  import Control.Monad+import Control.Monad.Except  import Data.Functor import Data.Maybe@@ -41,15 +42,15 @@ import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.MetaVars (metaType)+import Agda.TypeChecking.Monad.Pure import Agda.TypeChecking.Monad.Signature (HasConstInfo(..), applyDef) import Agda.TypeChecking.Pretty-import Agda.TypeChecking.ProjectionLike (elimView) import Agda.TypeChecking.Records (getDefType)+import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope -import Agda.Utils.Except import Agda.Utils.Impossible import Agda.Utils.Lens import Agda.Utils.Monad@@ -58,15 +59,17 @@ --   straight away, return that. Otherwise, return @UnivSort s@ and add a --   constraint to ensure we can compute the sort eventually. inferUnivSort-  :: (MonadReduce m, MonadConstraint m, HasOptions m)+  :: (PureTCM m, MonadConstraint m)   => Sort -> m Sort inferUnivSort s = do   s <- reduce s-  ui <- univInf-  case univSort' ui s of+  case univSort' s of     Just s' -> return s'     Nothing -> do-      addConstraint $ HasBiggerSort s+      -- Jesper, 2020-04-19: With the addition of Setωᵢ and the PTS+      -- rule SizeUniv : Setω, every sort (with no metas) now has a+      -- bigger sort, so we do not need to add a constraint.+      -- addConstraint $ HasBiggerSort s       return $ UnivSort s  sortFitsIn :: MonadConversion m => Sort -> Sort -> m ()@@ -82,13 +85,10 @@ -- | Infer the sort of a pi type. If we can compute the sort straight away, --   return that. Otherwise, return @PiSort a s2@ and add a constraint to --   ensure we can compute the sort eventually.-inferPiSort-  :: (MonadReduce m, MonadAddContext m, MonadDebug m)-  => Dom Type -> Abs Sort -> m Sort+inferPiSort :: PureTCM m => Dom Type -> Abs Sort -> m Sort inferPiSort a s2 = do   s1' <- reduce $ getSort a-  let a' = set lensSort s1' a-  s2' <- mapAbstraction a' reduce s2+  s2' <- mapAbstraction a reduce s2   -- we do instantiateFull here to perhaps remove some (flexible)   -- dependencies of s2 on var 0, thus allowing piSort' to reduce   s2' <- instantiateFull s2'@@ -102,7 +102,7 @@   --    addConstraint $ HasPTSRule s1 s2   --    return $ PiSort s1 s2 -  return $ piSort a' s2'+  return $ piSort (unEl <$> a) s1' s2'  -- | As @inferPiSort@, but for a nondependent function type. inferFunSort :: Sort -> Sort -> TCM Sort@@ -138,28 +138,35 @@ --  underAbstraction a b checkTelePiSort checkTelePiSort _ = return () -ifIsSort :: (MonadReduce m) => Type -> (Sort -> m a) -> m a -> m a+ifIsSort :: (MonadReduce m, MonadBlock m) => Type -> (Sort -> m a) -> m a -> m a ifIsSort t yes no = do-  t <- reduce t-  case unEl t of-    Sort s -> yes s-    _      -> no+  -- Jesper, 2020-09-06, subtle: do not use @abortIfBlocked@ here+  -- since we want to take the yes branch whenever the type is a sort,+  -- even if it is blocked.+  bt <- reduceB t+  case unEl (ignoreBlocking bt) of+    Sort s                     -> yes s+    _      | Blocked m _ <- bt -> patternViolation m+           | otherwise         -> no +ifNotSort :: (MonadReduce m, MonadBlock m) => Type -> m a -> (Sort -> m a) -> m a+ifNotSort t = flip $ ifIsSort t+ -- | Result is in reduced form. shouldBeSort-  :: (MonadReduce m, MonadTCEnv m, ReadTCState m, MonadError TCErr m)+  :: (PureTCM m, MonadBlock m, MonadError TCErr m)   => Type -> m Sort shouldBeSort t = ifIsSort t return (typeError $ ShouldBeASort t) --- | Reconstruct the sort of a type.+-- | Reconstruct the sort of a term. -- --   Precondition: given term is a well-sorted type. sortOf-  :: forall m. (MonadReduce m, MonadTCEnv m, MonadAddContext m, HasBuiltins m, HasConstInfo m)+  :: forall m. (PureTCM m, MonadBlock m)   => Term -> m Sort sortOf t = do   reportSDoc "tc.sort" 40 $ "sortOf" <+> prettyTCM t-  sortOfT =<< elimView True t+  sortOfT =<< elimView EvenLone t    where     sortOfT :: Term -> m Sort@@ -168,10 +175,8 @@         let a = unEl $ unDom adom         sa <- sortOf a         sb <- mapAbstraction adom (sortOf . unEl) b-        return $ piSort (adom $> El sa a) sb-      Sort s     -> do-        ui <- univInf-        return $ univSort ui s+        return $ piSort (unEl <$> adom) sa sb+      Sort s     -> return $ univSort s       Var i es   -> do         a <- typeOfBV i         sortOfE a (Var i) es@@ -190,9 +195,20 @@      sortOfE :: Type -> (Elims -> Term) -> Elims -> m Sort     sortOfE a hd []     = ifIsSort a return __IMPOSSIBLE__-    sortOfE a hd (e:es) = case e of-      Apply (Arg ai v) -> ifNotPiType a __IMPOSSIBLE__ $ \b c -> do-        sortOfE (c `absApp` v) (hd . (e:)) es+    sortOfE a hd (e:es) = do+     reportSDoc "tc.sort" 50 $ vcat+       [ "sortOfE"+       , "  a  = " <+> prettyTCM a+       , "  hd = " <+> prettyTCM (hd [])+       , "  e  = " <+> prettyTCM e+       ]+     case e of+      Apply (Arg ai v) -> do+        ba <- reduceB a+        case unEl (ignoreBlocking ba) of+          Pi b c -> sortOfE (c `absApp` v) (hd . (e:)) es+          _ | Blocked m _ <- ba -> patternViolation m+            | otherwise         -> __IMPOSSIBLE__       Proj o f -> do         a <- reduce a         ~(El _ (Pi b c)) <- fromMaybe __IMPOSSIBLE__ <$> getDefType f a@@ -201,3 +217,9 @@       IApply x y r -> do         (b , c) <- fromMaybe __IMPOSSIBLE__ <$> isPath a         sortOfE (c `absApp` r) (hd . (e:)) es++-- | Reconstruct the minimal sort of a type (ignoring the sort annotation).+sortOfType+  :: forall m. (PureTCM m, MonadBlock m)+  => Type -> m Sort+sortOfType = sortOf . unEl

src/full/Agda/TypeChecking/Substitute.hs view

@@ -1,7 +1,5 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE TypeApplications   #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications    #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -19,7 +17,7 @@   , Substitution'(..), Substitution   ) where -import Control.Arrow (second)+import Control.Arrow (first, second) import Control.Monad (guard) import Data.Coerce import Data.Function@@ -51,6 +49,8 @@ import Agda.Utils.Empty import Agda.Utils.Functor 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.Monad import Agda.Utils.Permutation@@ -67,7 +67,7 @@ --   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, Subst t t)+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 $@@ -104,7 +104,7 @@ canProject :: QName -> Term -> Maybe (Arg Term) canProject f v =   case v of-    (Con (ConHead _ _ fs) _ vs) -> do+    (Con (ConHead _ IsRecord{} _ fs) _ vs) -> do       (fld, i) <- findWithIndex ((f==) . unArg) fs       -- Jesper, 2019-10-17: dont unfold irrelevant projections       guard $ not $ isIrrelevant fld@@ -118,12 +118,14 @@ conApp fk ch                  ci args []             = Con ch ci args conApp fk ch                  ci args (a@Apply{} : es) = conApp @t fk ch ci (args ++ [a]) es conApp fk ch                  ci args (a@IApply{} : es) = conApp @t fk ch ci (args ++ [a]) es-conApp fk ch@(ConHead c _ fs) ci args ees@(Proj o f : es) =-  let failure err = flip trace err $-        "conApp: constructor " ++ show c ++-        " with fields\n" ++ unlines (map (("  " ++) . show) fs) ++-        " and args\n" ++ unlines (map (("  " ++) . prettyShow) args) ++-        " projected by " ++ show f+conApp fk ch@(ConHead c _ _ fs) ci args ees@(Proj o f : es) =+  let failure :: forall a. a -> a+      failure err = flip trace err $ concat+        [ "conApp: constructor ", prettyShow c+        , unlines $ " with fields" : map (("  " ++) . prettyShow) fs+        , unlines $ " and args"    : map (("  " ++) . prettyShow) args+        , " projected by ", prettyShow f+        ]       isApply e = fromMaybe (failure __IMPOSSIBLE__) $ isApplyElim e       stuck err = fk err (Con ch ci args) [Proj o f]       -- Recurse using the instance for 't', see @applyTermE@@@ -219,7 +221,7 @@  -- @applyE@ does not make sense for telecopes, definitions, clauses etc. -instance Subst Term a => Apply (Tele a) where+instance TermSubst a => Apply (Tele a) where   apply tel               []       = tel   apply EmptyTel          _        = __IMPOSSIBLE__   apply (ExtendTel _ tel) (t : ts) = lazyAbsApp tel (unArg t) `apply` ts@@ -244,6 +246,7 @@        , rewPats    = applySubst sub (rewPats r)        , rewRHS     = applyNLPatSubst sub (rewRHS r)        , rewType    = applyNLPatSubst sub (rewType r)+       , rewFromClause = rewFromClause r        }    applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -293,7 +296,7 @@  instance Apply Defn where   apply d [] = d-  apply d args = case d of+  apply d args@(arg1:args1) = case d of     Axiom{} -> d     DataOrRecSig n -> DataOrRecSig (n - length args)     GeneralizableVar{} -> d@@ -326,23 +329,10 @@                 , funExtLam         = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam                 }               where-                larg  = last args -- the record value+                larg  = last1 arg1 args1 -- the record value                 args' = [larg]                 isVar0 = case unArg larg of Var 0 [] -> True; _ -> False-{--    Function{ funClauses = cs, funCompiled = cc, funInv = inv-            , funProjection = Just p@Projection{ projIndex = n } }-        -- case: only applying parameters-      | size args < n -> d { funProjection = Just $ p `apply` args }-        -- case: apply also to record value-      | otherwise     ->-        d { funClauses        = apply cs args'-          , funCompiled       = apply cc args'-          , funInv            = apply inv args'-          , funProjection     = Just $ p { projIndex = 0 } -- Nothing ?-          }-      where args' = [last args]  -- the record value--}+     Datatype{ dataPars = np, dataClause = cl } ->       d { dataPars = np - size args         , dataClause     = apply cl args@@ -357,6 +347,7 @@       d { conPars = np - size args }     Primitive{ primClauses = cs } ->       d { primClauses = apply cs args }+    PrimitiveSort{} -> d    applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es @@ -369,7 +360,7 @@     -- It is assumed that we only apply a clause to "parameters", i.e.     -- arguments introduced by lambda lifting. The problem is that these aren't     -- necessarily the first elements of the clause telescope.-    apply cls@(Clause rl rf tel ps b t catchall recursive unreachable ell) args+    apply cls@(Clause rl rf tel ps b t catchall exact recursive unreachable ell) args       | length args > length ps = __IMPOSSIBLE__       | otherwise =       Clause rl rf@@ -378,6 +369,7 @@              (applySubst rho b)              (applySubst rho t)              catchall+             exact              recursive              unreachable              ell@@ -414,7 +406,7 @@         --    Δ′ ⊢ ρ′ : Δ[xⁱ:=v]         --  so we just need Δ[xⁱ:=v] ⊢ σ : Δ and then ρ = ρ′ ∘ σ.         --  That's achieved by σ = singletonS i v'.-        mkSub :: Subst a a => (Term -> a) -> Nat -> [NamedArg DeBruijnPattern] -> [Term] -> Substitution' a+        mkSub :: EndoSubst a => (Term -> a) -> Nat -> [NamedArg DeBruijnPattern] -> [Term] -> Substitution' a         mkSub _ _ [] [] = idS         mkSub tm n (p : ps) (v : vs) =           case namedArg p of@@ -422,7 +414,7 @@               where v' = raise (n - 1) v             DotP{}  -> mkSub tm n ps vs             ConP c _ ps' -> mkSub tm n (ps' ++ ps) (projections c v ++ vs)-            DefP o q ps' -> mkSub tm n (ps' ++ ps) vs+            DefP{}  -> __IMPOSSIBLE__             LitP{}  -> __IMPOSSIBLE__             ProjP{} -> __IMPOSSIBLE__             IApplyP _ _ _ (DBPatVar _ i) -> mkSub tm (n - 1) (substP i v' ps) vs `composeS` singletonS i (tm v')@@ -445,13 +437,21 @@             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)-            DefP _ q ps'        -> newTel n tel (ps' ++ ps) vs-            LitP{}              -> __IMPOSSIBLE__-            ProjP{}             -> __IMPOSSIBLE__+            DefP{}  -> __IMPOSSIBLE__+            LitP{}  -> __IMPOSSIBLE__+            ProjP{} -> __IMPOSSIBLE__             IApplyP _ _ _ (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs         newTel _ tel _ _ = __IMPOSSIBLE__ -        projections c v = [ relToDontCare ai $ applyE v [Proj ProjSystem f] | Arg ai f <- conFields c ]+        projections c v = [ relToDontCare ai $+                            -- #4528: We might have bogus terms here when printing a clause that+                            --        cannot be taken. To mitigate the problem we use a Def instead+                            --        a Proj elim for data constructors, which at least stops conApp+                            --        from crashing. See #4989 for not printing bogus terms at all.+                            case conDataRecord c of+                              IsData     -> Def f [Apply (Arg ai v)]+                              IsRecord{} -> applyE v [Proj ProjSystem f]+                          | Arg ai f <- conFields c ]          -- subTel i v (Δ₁ (xᵢ : A) Δ₂) = Δ₁ Δ₂[xᵢ = v]         subTel i v EmptyTel = __IMPOSSIBLE__@@ -462,7 +462,7 @@  instance Apply CompiledClauses where   apply cc args = case cc of-    Fail     -> Fail+    Fail hs -> Fail (drop len hs)     Done hs t       | length hs >= len ->          let sub = parallelS $ map var [0..length hs - len - 1] ++ map unArg args@@ -476,7 +476,7 @@   applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es  instance Apply ExtLamInfo where-  apply (ExtLamInfo m sys) args = ExtLamInfo m (apply sys args)+  apply (ExtLamInfo m b sys) args = ExtLamInfo m b (apply sys args)   applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es  instance Apply System where@@ -589,7 +589,7 @@ piApply t []                      = t piApply (El _ (Pi  _ b)) (a:args) = lazyAbsApp b (unArg a) `piApply` args piApply t args                    =-  trace ("piApply t = " ++ show t ++ "\n  args = " ++ show args) __IMPOSSIBLE__+  trace ("piApply t = " ++ prettyShow t ++ "\n  args = " ++ prettyShow args) __IMPOSSIBLE__  --------------------------------------------------------------------------- -- * Abstraction@@ -618,8 +618,8 @@ --   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) =-    RewriteRule q (abstract tel gamma) f ps rhs t+  abstract tel (RewriteRule q gamma f ps rhs t c) =+    RewriteRule q (abstract tel gamma) f ps rhs t c  instance {-# OVERLAPPING #-} Abstract [Occ.Occurrence] where   abstract tel []  = []@@ -667,15 +667,19 @@       -- Andreas, 2015-05-11 if projection was applied to Var 0       -- then abstract over last element of tel (the others are params).       if projIndex p > 0 then d' else-        d' { funClauses  = abstract tel1 cs+        d' { funClauses  = map (abstractClause tel1) cs            , funCompiled = abstract tel1 cc            , funCovering = abstract tel1 cov            , funInv      = abstract tel1 inv            , funExtLam   = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam            }         where-          d' = d { funProjection = Just $ abstract tel p }+          d' = d { funProjection = Just $ abstract tel p+                 , funClauses    = map (abstractClause EmptyTel) cs }           tel1 = telFromList $ drop (size tel - 1) $ telToList tel+          -- #5128: clause telescopes should be abstracted over the full telescope, regardless of+          --        projection shenanigans.+          abstractClause tel1 c = (abstract tel1 c) { clauseTel = abstract tel $ clauseTel c }      Datatype{ dataPars = np, dataClause = cl } ->       d { dataPars       = np + size tel@@ -690,28 +694,32 @@       d { conPars = np + size tel }     Primitive{ primClauses = cs } ->       d { primClauses = abstract tel cs }+    PrimitiveSort{} -> d  instance Abstract PrimFun where     abstract tel (PrimFun x ar def) = PrimFun x (ar + n) $ \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) =+  abstract tel (Clause rl rf tel' ps b t catchall exact recursive unreachable ell) =     Clause rl rf (abstract tel tel')            (namedTelVars m tel ++ ps)            b            t -- nothing to do for t, since it lives under the telescope            catchall+           exact            recursive            unreachable            ell       where m = size tel + size tel'  instance Abstract CompiledClauses where-  abstract tel Fail = Fail-  abstract tel (Done xs t) = Done (map (argFromDom . fmap fst) (telToList tel) ++ xs) t-  abstract tel (Case n bs) =-    Case (n <&> \ i -> i + size tel) (abstract tel bs)+  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)+    where+      hs = map (argFromDom . fmap fst) $ telToList tel  instance Abstract a => Abstract (WithArity a) where   abstract tel (WithArity n a) = WithArity n $ abstract tel a@@ -759,7 +767,7 @@ ---------------------------------------------------------------------------  -- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renaming _ π) : Term Γ -> Term Δ@-renaming :: forall a. DeBruijn a => Empty -> Permutation -> Substitution' a+renaming :: forall a. DeBruijn a => Impossible -> Permutation -> Substitution' a renaming err p = prependS err gamma $ raiseS $ size p   where     gamma :: [Maybe a]@@ -771,15 +779,16 @@ renamingR p@(Perm n _) = permute (reverseP p) (map deBruijnVar [0..]) ++# raiseS n  -- | The permutation should permute the corresponding context. (right-to-left list)-renameP :: Subst t a => Empty -> Permutation -> a -> a+renameP :: Subst a => Impossible -> Permutation -> a -> a renameP err p = applySubst (renaming err p) -instance Subst a a => Subst a (Substitution' a) where+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 #-}-applySubstTerm :: forall t. (Coercible t Term, Subst t t, Apply t) => Substitution' t -> t -> t+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@@ -794,68 +803,73 @@     DontCare mv -> dontCare $ sub @t mv     Dummy s es  -> Dummy s $ subE es  where-   sub :: forall a b. (Coercible b a, Subst t a) => b -> b+   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)) -instance Subst Term Term where+instance Subst Term where+  type SubstArg Term = Term   applySubst = applySubstTerm -instance Subst BraveTerm BraveTerm where+instance Subst BraveTerm where+  type SubstArg BraveTerm = BraveTerm   applySubst = applySubstTerm -instance (Coercible a Term, Subst t a, Subst t b) => Subst t (Type'' a b) where+instance (Coercible a Term, 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 t a) => Subst t (Sort' a) where-  applySubst rho s = case s of+instance (Coercible a Term, Subst a) => Subst (Sort' a) where+  type SubstArg (Sort' a) = SubstArg a+  applySubst rho = \case     Type n     -> Type $ sub n     Prop n     -> Prop $ sub n-    Inf        -> Inf+    Inf f n    -> Inf f n+    SSet n     -> SSet $ sub n     SizeUniv   -> SizeUniv-    PiSort a s2 -> coerce $ piSort (coerce $ sub a) (coerce $ sub s2)+    LockUniv   -> LockUniv+    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 Nothing $ coerce $ sub s+    UnivSort s -> coerce $ univSort $ coerce $ sub s     MetaS x es -> MetaS x $ sub es     DefS d es  -> DefS d $ sub es-    DummyS{}   -> s-    where sub x = applySubst rho x+    s@DummyS{} -> s+    where+      sub :: forall b. (Subst b, SubstArg a ~ SubstArg b) => b -> b+      sub x = applySubst rho x -instance Subst t a => Subst t (Level' a) where+instance Subst a => Subst (Level' a) where+  type SubstArg (Level' a) = SubstArg a   applySubst rho (Max n as) = Max n $ applySubst rho as -instance Subst t a => Subst t (PlusLevel' a) where+instance Subst a => Subst (PlusLevel' a) where+  type SubstArg (PlusLevel' a) = SubstArg a   applySubst rho (Plus n l) = Plus n $ applySubst rho l -instance Subst t a => Subst t (LevelAtom' a) where-  applySubst rho (MetaLevel m vs)   = MetaLevel m    $ applySubst rho vs-  applySubst rho (BlockedLevel m v) = BlockedLevel m $ applySubst rho v-  applySubst rho (NeutralLevel _ v) = UnreducedLevel $ applySubst rho v-  applySubst rho (UnreducedLevel v) = UnreducedLevel $ applySubst rho v--instance Subst Term Name where-  applySubst rho = id--instance {-# OVERLAPPING #-} Subst Term String where+instance Subst Name where+  type SubstArg Name = Term   applySubst rho = id -instance Subst Term ConPatternInfo where+instance Subst ConPatternInfo where+  type SubstArg ConPatternInfo = Term   applySubst rho i = i{ conPType = applySubst rho $ conPType i } -instance Subst Term Pattern where-  applySubst rho p = case p of-    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-    VarP o s     -> p-    LitP o l     -> p-    ProjP{}      -> p+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+    DotP o t        -> DotP o $ applySubst rho t+    p@(VarP _o _x)  -> p+    p@(LitP _o _l)  -> p+    p@(ProjP _o _x) -> p     IApplyP o t u x -> IApplyP o (applySubst rho t) (applySubst rho u) x -instance Subst Term A.ProblemEq where+instance Subst A.ProblemEq where+  type SubstArg A.ProblemEq = Term   applySubst rho (A.ProblemEq p v a) =     uncurry (A.ProblemEq p) $ applySubst rho (v,a) @@ -865,7 +879,7 @@  instance DeBruijn NLPat where   deBruijnVar i = PVar i []-  deBruijnView p = case p of+  deBruijnView = \case     PVar i []   -> Just i     PVar{}      -> Nothing     PDef{}      -> Nothing@@ -875,11 +889,11 @@     PBoundVar{} -> Nothing -- or... ?     PTerm{}     -> Nothing -- or... ? -applyNLPatSubst :: (Subst Term a) => Substitution' NLPat -> a -> a+applyNLPatSubst :: TermSubst a => Substitution' NLPat -> a -> a applyNLPatSubst = applySubst . fmap nlPatToTerm   where     nlPatToTerm :: NLPat -> Term-    nlPatToTerm p = case p of+    nlPatToTerm = \case       PVar i xs      -> Var i $ map (Apply . fmap var) xs       PTerm u        -> u       PDef f es      -> __IMPOSSIBLE__@@ -888,18 +902,19 @@       PSort s        -> __IMPOSSIBLE__       PBoundVar i es -> __IMPOSSIBLE__ -applyNLSubstToDom :: Subst NLPat a => Substitution' NLPat -> Dom a -> Dom a+applyNLSubstToDom :: SubstWith NLPat a => Substitution' NLPat -> Dom a -> Dom a applyNLSubstToDom rho dom = applySubst rho <$> dom{ domTactic = applyNLPatSubst rho $ domTactic dom } -instance Subst NLPat NLPat where-  applySubst rho p = case p of-    PVar 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+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+    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-    PTerm u -> PTerm $ applyNLPatSubst rho u+    PTerm u        -> PTerm $ applyNLPatSubst rho u      where       applyBV :: NLPat -> [Arg Int] -> NLPat@@ -912,114 +927,153 @@         PSort s        -> __IMPOSSIBLE__         PBoundVar i es -> __IMPOSSIBLE__ -instance Subst NLPat NLPType where+instance Subst NLPType where+  type SubstArg NLPType = NLPat   applySubst rho (NLPType s a) = NLPType (applySubst rho s) (applySubst rho a) -instance Subst NLPat NLPSort where+instance Subst NLPSort where+  type SubstArg NLPSort = NLPat   applySubst rho = \case     PType l   -> PType $ applySubst rho l     PProp l   -> PProp $ applySubst rho l-    PInf      -> PInf+    PInf f n  -> PInf f n     PSizeUniv -> PSizeUniv+    PLockUniv -> PLockUniv -instance Subst NLPat RewriteRule where-  applySubst rho (RewriteRule q gamma f ps rhs t) =+instance Subst RewriteRule where+  type SubstArg RewriteRule = NLPat+  applySubst rho (RewriteRule q gamma f ps rhs t c) =     RewriteRule q (applyNLPatSubst rho gamma)                 f (applySubst (liftS n rho) ps)                   (applyNLPatSubst (liftS n rho) rhs)                   (applyNLPatSubst (liftS n rho) t)+                  c     where n = size gamma -instance Subst t a => Subst t (Blocked a) where+instance Subst a => Subst (Blocked a) where+  type SubstArg (Blocked a) = SubstArg a   applySubst rho b = fmap (applySubst rho) b -instance Subst Term DisplayForm where+instance Subst DisplayForm where+  type SubstArg DisplayForm = Term   applySubst rho (Display n ps v) =-    Display n (applySubst (liftS 1 rho) ps)+    Display n (applySubst (liftS n rho) ps)               (applySubst (liftS n rho) v) -instance Subst Term DisplayTerm where+instance Subst DisplayTerm where+  type SubstArg DisplayTerm = Term   applySubst rho (DTerm v)        = DTerm $ applySubst rho v   applySubst rho (DDot v)         = DDot  $ applySubst rho v   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 t a => Subst t (Tele a) where+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) -instance Subst Term Constraint where-  applySubst rho c = case c of+instance Subst Constraint where+  type SubstArg Constraint = Term++  applySubst rho = \case     ValueCmp cmp a u v       -> ValueCmp cmp (rf a) (rf u) (rf v)     ValueCmpOnFace cmp p t u v -> ValueCmpOnFace cmp (rf p) (rf t) (rf u) (rf v)     ElimCmp ps fs a v e1 e2  -> ElimCmp ps fs (rf a) (rf v) (rf e1) (rf e2)-    TelCmp a b cmp tel1 tel2 -> TelCmp (rf a) (rf b) cmp (rf tel1) (rf tel2)     SortCmp cmp s1 s2        -> SortCmp cmp (rf s1) (rf s2)     LevelCmp cmp l1 l2       -> LevelCmp cmp (rf l1) (rf l2)-    Guarded c cs             -> Guarded (rf c) cs     IsEmpty r a              -> IsEmpty r (rf a)     CheckSizeLtSat t         -> CheckSizeLtSat (rf t)-    FindInstance m b cands   -> FindInstance m b (rf cands)-    UnBlock{}                -> c-    CheckFunDef{}            -> c+    FindInstance m cands     -> FindInstance m (rf cands)+    c@UnBlock{}              -> c+    c@CheckFunDef{}          -> c     HasBiggerSort s          -> HasBiggerSort (rf s)     HasPTSRule a s           -> HasPTSRule (rf a) (rf s)-    UnquoteTactic m t h g    -> UnquoteTactic m (rf t) (rf h) (rf g)+    CheckLockedVars a b c d  -> CheckLockedVars (rf a) (rf b) (rf c) (rf d)+    UnquoteTactic t h g      -> UnquoteTactic (rf t) (rf h) (rf g)     CheckMetaInst m          -> CheckMetaInst m+    UsableAtModality mod m   -> UsableAtModality mod (rf m)     where+      rf :: forall a. TermSubst a => a -> a       rf x = applySubst rho x -instance Subst Term CompareAs where+instance Subst CompareAs where+  type SubstArg CompareAs = Term   applySubst rho (AsTermsOf a) = AsTermsOf $ applySubst rho a   applySubst rho AsSizes       = AsSizes   applySubst rho AsTypes       = AsTypes -instance Subst t a => Subst t (Elim' a) where-  applySubst rho e = case e of-    Apply v -> Apply $ applySubst rho v+instance Subst a => Subst (Elim' a) where+  type SubstArg (Elim' a) = SubstArg a+  applySubst rho = \case+    Apply v      -> Apply $ applySubst rho v     IApply x y r -> IApply (applySubst rho x) (applySubst rho y) (applySubst rho r)-    Proj{}  -> e+    e@Proj{}     -> e -instance Subst t a => Subst t (Abs a) where+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 -instance Subst t a => Subst t (Arg a) where+instance Subst a => Subst (Arg a) where+  type SubstArg (Arg a) = SubstArg a   applySubst IdS arg = arg   applySubst rho arg = setFreeVariables unknownFreeVariables $ fmap (applySubst rho) arg -instance Subst t a => Subst t (Named name a) where+instance Subst a => Subst (Named name a) where+  type SubstArg (Named name a) = SubstArg a   applySubst rho = fmap (applySubst rho) -instance (Subst t a, Subst t b) => Subst t (Dom' a b) where+instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (Dom' a b) where+  type SubstArg (Dom' a b) = SubstArg a+   applySubst IdS dom = dom   applySubst rho dom = setFreeVariables unknownFreeVariables $     fmap (applySubst rho) dom{ domTactic = applySubst rho (domTactic dom) } -instance Subst t a          => Subst t (Maybe a)      where-instance Subst t a          => Subst t [a]            where-instance (Ord k, Subst t a) => Subst t (Map k a)      where-instance Subst t a          => Subst t (WithHiding a) where+instance Subst a => Subst (Maybe a) where+  type SubstArg (Maybe a) = SubstArg a -instance Subst Term () where+instance Subst a => Subst [a] where+  type SubstArg [a] = SubstArg a++instance (Ord k, Subst a) => Subst (Map k a) where+  type SubstArg (Map k a) = SubstArg a++instance Subst a => Subst (WithHiding a) where+  type SubstArg (WithHiding a) = SubstArg a++instance Subst () where+  type SubstArg () = Term   applySubst _ _ = () -instance (Subst t a, Subst t b) => Subst t (a, b) where+instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (a, b) where+  type SubstArg (a, b) = SubstArg a   applySubst rho (x,y) = (applySubst rho x, applySubst rho y) -instance (Subst t a, Subst t b, Subst t c) => Subst t (a, b, c) where+instance (Subst a, Subst b, Subst c, SubstArg a ~ SubstArg b, SubstArg b ~ SubstArg c) => Subst (a, b, c) where+  type SubstArg (a, b, c) = SubstArg a   applySubst rho (x,y,z) = (applySubst rho x, applySubst rho y, applySubst rho z) -instance (Subst t a, Subst t b, Subst t c, Subst t d) => Subst t (a, b, c, d) where+instance+  ( Subst a, Subst b, Subst c, Subst d+  , SubstArg a ~ SubstArg b+  , SubstArg b ~ SubstArg c+  , SubstArg c ~ SubstArg d+  ) => Subst (a, b, c, d) where+  type SubstArg (a, b, c, d) = SubstArg a   applySubst rho (x,y,z,u) = (applySubst rho x, applySubst rho y, applySubst rho z, applySubst rho u) -instance Subst Term Candidate where-  applySubst rho (Candidate u t ov) = Candidate (applySubst rho u) (applySubst rho t) ov+instance Subst Candidate where+  type SubstArg Candidate = Term+  applySubst rho (Candidate q u t ov) = Candidate q (applySubst rho u) (applySubst rho t) ov -instance Subst Term EqualityView where+instance Subst EqualityView where+  type SubstArg EqualityView = Term   applySubst rho (OtherType t) = OtherType     (applySubst rho t)+  applySubst rho (IdiomType t) = IdiomType+    (applySubst rho t)   applySubst rho (EqualityType s eq l t a b) = EqualityType     (applySubst rho s)     eq@@ -1037,7 +1091,7 @@ fromPatternSubstitution :: PatternSubstitution -> Substitution fromPatternSubstitution = fmap patternToTerm -applyPatSubst :: (Subst Term a) => PatternSubstitution -> a -> a+applyPatSubst :: TermSubst a => PatternSubstitution -> a -> a applyPatSubst = applySubst . fromPatternSubstitution  @@ -1061,22 +1115,24 @@     ProjP{} -> __IMPOSSIBLE__     (IApplyP _ t u x) -> IApplyP i t u x -instance Subst DeBruijnPattern DeBruijnPattern where-  applySubst IdS p = p-  applySubst rho p = case p of+instance Subst DeBruijnPattern where+  type SubstArg DeBruijnPattern = DeBruijnPattern+  applySubst IdS = id+  applySubst rho = \case     VarP i x     ->       usePatternInfo i $       useName (dbPatVarName x) $       lookupS rho $ dbPatVarIndex x     DotP i u     -> DotP i $ applyPatSubst rho u-    ConP c ci ps -> ConP c ci $ 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-    LitP i x     -> p-    ProjP{}      -> p-    IApplyP i t u x -> case useName (dbPatVarName x) $ lookupS rho $ dbPatVarIndex x of-                        IApplyP _ _ _ y -> IApplyP i (applyPatSubst rho t) (applyPatSubst rho u) y-                        VarP  _ y -> IApplyP i (applyPatSubst rho t) (applyPatSubst rho u) y-                        _ -> __IMPOSSIBLE__+    p@(LitP _ _) -> p+    p@ProjP{}    -> p+    IApplyP i t u x ->+      case useName (dbPatVarName x) $ lookupS rho $ dbPatVarIndex x of+        IApplyP _ _ _ y -> IApplyP i (applyPatSubst rho t) (applyPatSubst rho u) y+        VarP  _ y       -> IApplyP i (applyPatSubst rho t) (applyPatSubst rho u) y+        _ -> __IMPOSSIBLE__     where       useName :: PatVarName -> DeBruijnPattern -> DeBruijnPattern       useName n (VarP o x)@@ -1084,7 +1140,8 @@         = VarP o $ x { dbPatVarName = n }       useName _ x = x -instance Subst Term Range where+instance Subst Range where+  type SubstArg Range = Term   applySubst _ = id  ---------------------------------------------------------------------------@@ -1124,8 +1181,8 @@ data TelV a  = TelV { theTel :: Tele (Dom a), theCore :: a }   deriving (Show, Functor) -deriving instance (Subst Term a, Eq  a) => Eq  (TelV a)-deriving instance (Subst Term a, Ord a) => Ord (TelV a)+deriving instance (TermSubst a, Eq  a) => Eq  (TelV a)+deriving instance (TermSubst a, Ord a) => Ord (TelV a)  -- | Takes off all exposed function domains from the given type. --   This means that it does not reduce to expose @Pi@-types.@@ -1153,12 +1210,21 @@ bindsToTel :: [Name] -> Dom Type -> ListTel bindsToTel = bindsToTel' nameToArgName +bindsToTel'1 :: (Name -> a) -> List1 Name -> Dom Type -> ListTel' a+bindsToTel'1 f = bindsToTel' f . List1.toList++bindsToTel1 :: List1 Name -> Dom Type -> ListTel+bindsToTel1 = bindsToTel . List1.toList+ -- | Turn a typed binding @(x1 .. xn : A)@ into a telescope. 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) +namedBindsToTel1 :: List1 (NamedArg Name) -> Type -> Telescope+namedBindsToTel1 = namedBindsToTel . List1.toList+ domFromNamedArgName :: NamedArg Name -> Dom () domFromNamedArgName x = () <$ domFromNamedArg (fmap forceName x)   where@@ -1168,24 +1234,35 @@  -- ** Abstracting in terms and types +mkPiSort :: Dom Type -> Abs Type -> Sort+mkPiSort a b = piSort (unEl <$> a) (getSort $ unDom a) (getSort <$> b)+ -- | @mkPi dom t = telePi (telFromList [dom]) t@ mkPi :: Dom (ArgName, Type) -> Type -> Type mkPi !dom b = el $ Pi a (mkAbs x b)   where     x = fst $ unDom dom     a = snd <$> dom-    el = El $ piSort a (Abs x (getSort b)) -- piSort checks x freeIn+    el = El $ mkPiSort a (Abs x b)  mkLam :: Arg ArgName -> Term -> Term mkLam a v = Lam (argInfo a) (Abs (unArg a) v) +lamView :: Term -> ([Arg ArgName], Term)+lamView (Lam h (Abs   x b)) = first (Arg h x :) $ lamView b+lamView (Lam h (NoAbs x b)) = first (Arg h x :) $ lamView (raise 1 b)+lamView t                   = ([], t)++unlamView :: [Arg ArgName] -> Term -> Term+unlamView xs b = foldr mkLam b xs+ telePi' :: (Abs Type -> Abs Type) -> Telescope -> Type -> Type telePi' reAbs = telePi where   telePi EmptyTel          t = t   telePi (ExtendTel u tel) t = el $ Pi u $ reAbs b     where       b  = (`telePi` t) <$> tel-      el = El $ piSort u (getSort <$> b)+      el = El $ mkPiSort u b  -- | Uses free variable analysis to introduce 'NoAbs' bindings. telePi :: Telescope -> Type -> Type@@ -1205,7 +1282,7 @@     -- If u is not declared visible and b can be strengthened, skip quantification of u.     | notVisible u, NoAbs x t' <- b' = t'     -- Otherwise, include quantification over u.-    | otherwise = El (piSort u $ getSort <$> b) $ Pi u b+    | otherwise = El (mkPiSort u b) $ Pi u b   where     b  = tel <&> (`telePiVisible` t)     b' = reAbs b@@ -1265,10 +1342,11 @@ deriving instance Eq PlusLevel deriving instance Eq NotBlocked deriving instance Eq t => Eq (Blocked t)+deriving instance Eq CandidateKind deriving instance Eq Candidate -deriving instance (Subst t a, Eq a)  => Eq  (Tele a)-deriving instance (Subst t a, Ord a) => Ord (Tele a)+deriving instance (Subst a, Eq a)  => Eq  (Tele a)+deriving instance (Subst a, Ord a) => Ord (Tele a)  -- Andreas, 2019-11-16, issue #4201: to avoid potential unintended -- performance loss, the Eq instance for Constraint is disabled:@@ -1284,19 +1362,12 @@ -- Therefore, I hope this comment is sufficient to prevent a resurrection -- of the Eq instance for Constraint. -deriving instance Eq CompareAs deriving instance Eq Section  instance Ord PlusLevel where   -- Compare on the atom first. Makes most sense for levelMax.   compare (Plus n a) (Plus m b) = compare (a,n) (b,m) -instance Eq LevelAtom where-  (==) = (==) `on` unLevelAtom--instance Ord LevelAtom where-  compare = compare `on` unLevelAtom- -- | Syntactic 'Type' equality, ignores sort annotations. instance Eq a => Eq (Type' a) where   (==) = (==) `on` unEl@@ -1385,23 +1456,23 @@ -- | Equality of binders relies on weakening --   which is a special case of renaming --   which is a special case of substitution.-instance (Subst t a, Eq a) => Eq (Abs a) where+instance (Subst a, Eq a) => Eq (Abs a) where   NoAbs _ a == NoAbs _ b = a == b  -- no need to raise if both are NoAbs   a         == b         = absBody a == absBody b -instance (Subst t a, Ord a) => Ord (Abs a) where+instance (Subst a, Ord a) => Ord (Abs a) where   NoAbs _ a `compare` NoAbs _ b = a `compare` b  -- no need to raise if both are NoAbs   a         `compare` b         = absBody a `compare` absBody b  deriving instance Ord a => Ord (Dom a) -instance (Subst t a, Eq a)  => Eq  (Elim' a) where+instance (Subst a, 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 t a, Ord a) => Ord (Elim' a) where+instance (Subst a, 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'@@ -1416,37 +1487,69 @@ ---------------------------------------------------------------------------  -- | @univSort' univInf s@ gets the next higher sort of @s@, if it is---   known (i.e. it is not just @UnivSort s@). @univInf@ is returned---   as the sort of @Inf@.+--   known (i.e. it is not just @UnivSort s@). -- --   Precondition: @s@ is reduced-univSort' :: Maybe Sort -> Sort -> Maybe Sort-univSort' univInf (Type l) = Just $ Type $ levelSuc l-univSort' univInf (Prop l) = Just $ Type $ levelSuc l-univSort' univInf Inf      = univInf-univSort' univInf s        = Nothing+univSort' :: Sort -> Maybe Sort+univSort' (Type l) = Just $ Type $ levelSuc l+univSort' (Prop l) = Just $ Type $ levelSuc l+univSort' (Inf f n) = Just $ Inf f $ 1 + n+univSort' (SSet l) = Just $ SSet $ levelSuc l+univSort' SizeUniv = Just $ Inf IsFibrant 0+univSort' LockUniv = Just $ Inf IsFibrant 0 -- lock polymorphism is not actually supported+univSort' s        = Nothing -univSort :: Maybe Sort -> Sort -> Sort-univSort univInf s = fromMaybe (UnivSort s) $ univSort' univInf s+univSort :: Sort -> Sort+univSort s = fromMaybe (UnivSort s) $ univSort' s -univInf :: (HasOptions m) => m (Maybe Sort)-univInf =-  ifM ((optOmegaInOmega <$> pragmaOptions) `or2M` typeInType)-  {-then-} (return $ Just Inf)-  {-else-} (return Nothing)+sort :: Sort -> Type+sort s = El (univSort s) $ Sort s +ssort :: Level -> Type+ssort l = sort (SSet l)++-- | Returns @Nothing@ for unknown (meta) sorts, and otherwise returns+--   @Just (b,f)@ where @b@ indicates smallness and @f@ fibrancy.+--   I.e., @b@ is @True@ for (relatively) small sorts like @Set l@ and+--   @Prop l@, and instead @b@ is @False@ for large sorts such as @Setω@.+isSmallSort :: Sort -> Maybe (Bool,IsFibrant)+isSmallSort Type{}     = Just (True,IsFibrant)+isSmallSort Prop{}     = Just (True,IsFibrant)+isSmallSort SizeUniv   = Just (True,IsFibrant)+isSmallSort LockUniv   = Just (True,IsFibrant)+isSmallSort (Inf f _)  = Just (False,f)+isSmallSort SSet{}     = Just (True,IsStrict)+isSmallSort MetaS{}    = Nothing+isSmallSort FunSort{}  = Nothing+isSmallSort PiSort{}   = Nothing+isSmallSort UnivSort{} = Nothing+isSmallSort DefS{}     = Nothing+isSmallSort DummyS{}   = Nothing++fibrantLub :: IsFibrant -> IsFibrant -> IsFibrant+fibrantLub IsStrict a = IsStrict+fibrantLub a IsStrict = IsStrict+fibrantLub a b = a+ -- | Compute the sort of a function type from the sorts of its --   domain and codomain. funSort' :: Sort -> Sort -> Maybe Sort funSort' a b = case (a, b) of-  (Inf           , _            ) -> Just Inf-  (_             , Inf          ) -> Just Inf-  (Type a , Type b) -> Just $ Type $ levelLub a b+  (Inf af m      , Inf bf n     ) -> Just $ Inf (fibrantLub af bf) $ max m n+  (Inf af m      , b            ) | Just (True,bf) <- isSmallSort b -> Just $ Inf (fibrantLub af bf) m+  (a             , Inf bf n     ) | Just (True,af) <- isSmallSort a -> Just $ Inf (fibrantLub af bf) n+  (Type a        , Type b       ) -> Just $ Type $ levelLub a b+  (LockUniv      , b            ) -> Just b+  -- No functions into lock types+  (a             , LockUniv     ) -> Nothing   (SizeUniv      , b            ) -> Just b-  (_             , SizeUniv     ) -> Just SizeUniv-  (Prop a , Type b) -> Just $ Type $ levelLub a b-  (Type a , Prop b) -> Just $ Prop $ levelLub a b-  (Prop a , Prop b) -> Just $ Prop $ levelLub a b+  (a             , SizeUniv     ) | Just (True,_) <- isSmallSort a -> Just SizeUniv+  (Prop a        , Type b       ) -> Just $ Type $ levelLub a b+  (Type a        , Prop b       ) -> Just $ Prop $ levelLub a b+  (Prop a        , Prop b       ) -> Just $ Prop $ levelLub a b+  (SSet a        , SSet b       ) -> Just $ SSet $ levelLub a b+  (Type a        , SSet b       ) -> Just $ SSet $ levelLub a b+  (SSet a        , Type b       ) -> Just $ SSet $ levelLub a b   (a             , b            ) -> Nothing  funSort :: Sort -> Sort -> Sort@@ -1454,15 +1557,18 @@  -- | Compute the sort of a pi type from the sorts of its domain --   and codomain.-piSort' :: Dom Type -> Abs Sort -> Maybe Sort-piSort' a      (NoAbs _ b) = funSort' (getSort a) b-piSort' a bAbs@(Abs   _ b) = case flexRigOccurrenceIn 0 b of-  Nothing -> Just $ funSort (getSort a) $ noabsApp __IMPOSSIBLE__ bAbs-  Just o -> case o of-    StronglyRigid -> Just Inf-    Unguarded     -> Just Inf-    WeaklyRigid   -> Just Inf+piSort' :: Dom Term -> Sort -> Abs Sort -> Maybe Sort+piSort' a s1       (NoAbs _ s2) = Just $ FunSort s1 s2+piSort' a s1 s2Abs@(Abs   _ s2) = case flexRigOccurrenceIn 0 s2 of+  Nothing -> Just $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs+  Just o | Just (True, f1) <- isSmallSort s1, Just (True, f2) <- isSmallSort s2 -> case o of+    StronglyRigid -> Just $ Inf (fibrantLub f1 f2) 0+    Unguarded     -> Just $ Inf (fibrantLub f1 f2) 0+    WeaklyRigid   -> Just $ Inf (fibrantLub f1 f2) 0     Flexible _    -> Nothing+  Just o | Inf f1 n <- s1 , Just (True, f2) <- isSmallSort s2 -> Just $ Inf (fibrantLub f1 f2) n+  Just _ -> Nothing+ -- 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@@ -1492,11 +1598,10 @@ --     WeaklyRigid   -> Just Inf --     Flexible _    -> Nothing -piSort :: Dom Type -> Abs Sort -> Sort-piSort a b = case piSort' a b of-  Just s -> s-  Nothing | NoAbs _ b' <- b -> FunSort (getSort a) b'-          | otherwise       -> PiSort a b+piSort :: Dom Term -> Sort -> Abs Sort -> Sort+piSort a s1 s2 = case piSort' a s1 s2 of+  Just s  -> s+  Nothing -> PiSort a s1 s2  --------------------------------------------------------------------------- -- * Level stuff@@ -1506,7 +1611,7 @@ levelMax :: Integer -> [PlusLevel] -> Level levelMax n0 as0 = Max n as   where-    -- step 1: flatten nested @Level@ expressions in @LevelAtom@s+    -- step 1: flatten nested @Level@ expressions in @PlusLevel@s     Max n1 as1 = expandLevel $ Max n0 as0     -- step 2: remove subsumed @PlusLevel@s     as2       = removeSubsumed as1@@ -1525,18 +1630,10 @@     expandLevel (Max m as) = lmax m [] $ map expandPlus as      expandPlus :: PlusLevel -> Level-    expandPlus (Plus m l) = levelPlus m $ expandAtom l+    expandPlus (Plus m l) = levelPlus m (expandTm l) -    expandAtom :: LevelAtom -> Level-    expandAtom l = case l of-      BlockedLevel _ v -> expandTm v-      NeutralLevel _ v -> expandTm v-      UnreducedLevel v -> expandTm v-      MetaLevel{}      -> Max 0 [Plus 0 l]-      where-        expandTm (Level l)       = expandLevel l-        expandTm (Sort (Type l)) = expandLevel l -- TODO: get rid of this horrible hack!-        expandTm v               = Max 0 [Plus 0 l]+    expandTm (Level l)       = expandLevel l+    expandTm l               = atomicLevel l      removeSubsumed [] = []     removeSubsumed (Plus n a : bs)@@ -1553,11 +1650,5 @@ levelTm :: Level -> Term levelTm l =   case l of-    Max 0 [Plus 0 l] -> unLevelAtom l+    Max 0 [Plus 0 l] -> l     _                -> Level l--unLevelAtom :: LevelAtom -> Term-unLevelAtom (MetaLevel x es)   = MetaV x es-unLevelAtom (NeutralLevel _ v) = v-unLevelAtom (UnreducedLevel v) = v-unLevelAtom (BlockedLevel _ v) = v

src/full/Agda/TypeChecking/Substitute/Class.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-}  module Agda.TypeChecking.Substitute.Class where @@ -62,35 +61,45 @@ -- ----------- -- Γ ⊢ tρ : Aρ -class DeBruijn t => Subst t a | a -> t where-  applySubst :: Substitution' t -> a -> a+class DeBruijn (SubstArg a) => Subst a where+  type SubstArg a+  applySubst :: Substitution' (SubstArg a) -> a -> a -  default applySubst :: (a ~ f b, Functor f, Subst t b) => Substitution' t -> a -> a+  default applySubst :: (a ~ f b, Functor f, Subst b, SubstArg a ~ SubstArg b) => Substitution' (SubstArg a) -> a -> a   applySubst rho = fmap (applySubst rho) +-- | 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+type EndoSubst a = SubstWith a a++-- | `Subst` instance whose argument type is `Term`+type TermSubst a = SubstWith Term a+ -- | Raise de Bruijn index, i.e. weakening-raise :: Subst t a => Nat -> a -> a+raise :: Subst a => Nat -> a -> a raise = raiseFrom 0 -raiseFrom :: Subst t a => Nat -> Nat -> a -> a-raiseFrom n k = applySubst (liftS n $ raiseS k)+raiseFrom :: Subst a => Nat -> Nat -> a -> a+raiseFrom n k = applySubst (raiseFromS n k)  -- | Replace de Bruijn index i by a 'Term' in something.-subst :: Subst t a => Int -> t -> a -> a+subst :: Subst a => Int -> SubstArg a -> a -> a subst i u = applySubst $ singletonS i u -strengthen :: Subst t a => Empty -> a -> a+strengthen :: Subst a => Impossible -> a -> a strengthen err = applySubst (compactS err [Nothing])  -- | Replace what is now de Bruijn index 0, but go under n binders. --   @substUnder n u == subst n (raise n u)@.-substUnder :: Subst t a => Nat -> t -> a -> a+substUnder :: Subst a => Nat -> SubstArg a -> a -> a substUnder n u = applySubst (liftS n (singletonS 0 u))  -- ** Identity instances -instance Subst Term QName where+instance Subst QName where+  type SubstArg QName = Term   applySubst _ q = q  ---------------------------------------------------------------------------@@ -133,7 +142,7 @@ --    --------------------------------- --    Γ, A, Δ ⊢ inplace |Δ| u : Γ, A, Δ --   @-inplaceS :: Subst a a => Int -> a -> Substitution' a+inplaceS :: EndoSubst a => Int -> a -> Substitution' a inplaceS k u = singletonS k u `composeS` liftS (k + 1) (raiseS 1)  -- | Lift a substitution under k binders.@@ -156,10 +165,10 @@ dropS n (Strengthen _ rho) = dropS (n - 1) rho dropS n (Lift 0 rho)       = __IMPOSSIBLE__ dropS n (Lift m rho)       = wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho-dropS n (EmptyS err)       = absurd err+dropS n (EmptyS err)       = throwImpossible err  -- | @applySubst (ρ `composeS` σ) v == applySubst ρ (applySubst σ v)@-composeS :: Subst a a => Substitution' a -> Substitution' a -> Substitution' a+composeS :: EndoSubst a => Substitution' a -> Substitution' a -> Substitution' a composeS rho IdS = rho composeS IdS sgm = sgm composeS rho (EmptyS err) = EmptyS err@@ -174,12 +183,12 @@ --   Γ ⊢ σ : Δ --   Γ ⊢ δ : Θσ splitS :: Int -> Substitution' a -> (Substitution' a, Substitution' a)-splitS 0 rho                  = (rho, EmptyS __IMPOSSIBLE__)+splitS 0 rho                  = (rho, EmptyS impossible) splitS n (u :# rho)           = second (u :#) $ splitS (n - 1) rho splitS n (Strengthen err rho) = second (Strengthen err) $ splitS (n - 1) rho splitS n (Lift 0 _)           = __IMPOSSIBLE__ splitS n (Wk m rho)           = wkS m *** wkS m $ splitS n rho-splitS n IdS                  = (raiseS n, liftS n $ EmptyS __IMPOSSIBLE__)+splitS n IdS                  = (raiseS n, liftS n $ EmptyS impossible) splitS n (Lift m rho)         = wkS 1 *** liftS 1 $ splitS (n - 1) (liftS (m - 1) rho) splitS n (EmptyS err)         = __IMPOSSIBLE__ @@ -193,7 +202,7 @@ --      ----------------------------- (treating Nothing as having any type) --        Γ ⊢ prependS vs ρ : Δ, Θ --   @-prependS :: DeBruijn a => Empty -> [Maybe a] -> Substitution' a -> Substitution' a+prependS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a -> Substitution' a prependS err us rho = foldr f rho us   where     f Nothing  rho = Strengthen err rho@@ -202,14 +211,14 @@ parallelS :: DeBruijn a => [a] -> Substitution' a parallelS us = us ++# idS -compactS :: DeBruijn a => Empty -> [Maybe a] -> Substitution' a+compactS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a compactS err us = prependS err us idS  -- | Γ ⊢ (strengthenS ⊥ |Δ|) : Γ,Δ-strengthenS :: Empty -> Int -> Substitution' a+strengthenS :: Impossible -> Int -> Substitution' a strengthenS err = indexWithDefault __IMPOSSIBLE__ $ iterate (Strengthen err) idS -lookupS :: Subst a a => Substitution' a -> Nat -> a+lookupS :: EndoSubst a => Substitution' a -> Nat -> a lookupS rho i = case rho of   IdS                    -> deBruijnVar i   Wk n IdS               -> let j = i + n in@@ -219,52 +228,56 @@              | i < 0     -> __IMPOSSIBLE__              | otherwise -> lookupS rho (i - 1)   Strengthen err rho-             | i == 0    -> absurd err+             | i == 0    -> throwImpossible err              | i < 0     -> __IMPOSSIBLE__              | otherwise -> lookupS rho (i - 1)   Lift n rho | i < n     -> deBruijnVar i              | otherwise -> raise n $ lookupS rho (i - n)-  EmptyS err             -> absurd err+  EmptyS err             -> throwImpossible err   -- | lookupS (listS [(x0,t0)..(xn,tn)]) xi = ti, assuming x0 < .. < xn. -listS :: Subst a a => [(Int,a)] -> Substitution' a+listS :: EndoSubst a => [(Int,a)] -> Substitution' a listS ((i,t):ts) = singletonS i t `composeS` listS ts listS []         = IdS +-- | @Γ, Ξ, Δ ⊢ raiseFromS |Δ| |Ξ| : Γ, Δ@+raiseFromS :: Nat -> Nat -> Substitution' a+raiseFromS n k = liftS n $ raiseS k + --------------------------------------------------------------------------- -- * Functions on abstractions --   and things we couldn't do before we could define 'absBody' ---------------------------------------------------------------------------  -- | Instantiate an abstraction. Strict in the term.-absApp :: Subst t a => Abs a -> t -> a+absApp :: Subst a => Abs a -> SubstArg a -> a absApp (Abs   _ v) u = subst 0 u v absApp (NoAbs _ v) _ = v  -- | Instantiate an abstraction. Lazy in the term, which allow it to be --   __IMPOSSIBLE__ in the case where the variable shouldn't be used but we --   cannot use 'noabsApp'. Used in Apply.-lazyAbsApp :: Subst t a => Abs a -> t -> a+lazyAbsApp :: Subst a => Abs a -> SubstArg a -> a lazyAbsApp (Abs   _ v) u = applySubst (u :# IdS) v  -- Note: do not use consS here! lazyAbsApp (NoAbs _ v) _ = v  -- | Instantiate an abstraction that doesn't use its argument.-noabsApp :: Subst t a => Empty -> Abs a -> a+noabsApp :: Subst a => Impossible -> Abs a -> a noabsApp err (Abs   _ v) = strengthen err v noabsApp _   (NoAbs _ v) = v -absBody :: Subst t a => Abs a -> a+absBody :: Subst a => Abs a -> a absBody (Abs   _ v) = v absBody (NoAbs _ v) = raise 1 v -mkAbs :: (Subst t a, Free a) => ArgName -> a -> Abs a+mkAbs :: (Subst a, Free a) => ArgName -> a -> Abs a mkAbs x v | 0 `freeIn` v = Abs x v           | otherwise    = NoAbs x (raise (-1) v) -reAbs :: (Subst t a, Free a) => Abs a -> Abs a+reAbs :: (Subst a, Free a) => Abs a -> Abs a reAbs (NoAbs x v) = NoAbs x v reAbs (Abs x v)   = mkAbs x v @@ -274,8 +287,8 @@ --   at point of application of @k@ and the content of @b@ --   are at the same context. --   Precondition: @a@ and @b@ are at the same context at call time.-underAbs :: Subst t a => (a -> b -> b) -> a -> Abs b -> Abs b-underAbs cont a b = case b of+underAbs :: Subst a => (a -> b -> b) -> a -> Abs b -> Abs b+underAbs cont a = \case   Abs   x t -> Abs   x $ cont (raise 1 a) t   NoAbs x t -> NoAbs x $ cont a t @@ -283,9 +296,9 @@ --   performs operation @k@ on @a@ and the body of @b@, --   and puts the 'Lam's back.  @a@ is raised correctly --   according to the number of abstractions.-underLambdas :: Subst Term a => Int -> (a -> Term -> Term) -> a -> Term -> Term-underLambdas n cont a = loop n a where-  loop 0 a v = cont a v-  loop n a v = case v of+underLambdas :: TermSubst a => Int -> (a -> Term -> Term) -> a -> Term -> Term+underLambdas n cont = loop n where+  loop 0 a = cont a+  loop n a = \case     Lam h b -> Lam h $ underAbs (loop $ n-1) a b     _       -> __IMPOSSIBLE__

src/full/Agda/TypeChecking/Substitute/DeBruijn.hs view

@@ -29,15 +29,6 @@       Level l -> deBruijnView l       _ -> Nothing -instance DeBruijn LevelAtom where-  deBruijnVar = NeutralLevel ReallyNotBlocked . deBruijnVar-  deBruijnView l =-    case l of-      NeutralLevel _ u -> deBruijnView u-      UnreducedLevel u -> deBruijnView u-      MetaLevel{}    -> Nothing-      BlockedLevel{} -> Nothing- instance DeBruijn PlusLevel where   deBruijnVar = Plus 0 . deBruijnVar   deBruijnView l =

src/full/Agda/TypeChecking/SyntacticEquality.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE UndecidableInstances #-}- -- | A syntactic equality check that takes meta instantiations into account, --   but does not reduce.  It replaces --   @@@ -11,10 +9,8 @@  module Agda.TypeChecking.SyntacticEquality (SynEq, checkSyntacticEquality) where -import Prelude hiding (mapM)- import Control.Arrow ((***))-import Control.Monad.State hiding (mapM)+import Control.Monad.State  import Agda.Interaction.Options (optSyntacticEquality) @@ -23,7 +19,6 @@  import Agda.TypeChecking.Monad (ReduceM, MonadReduce(..), pragmaOptions, isInstantiatedMeta) import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute  import Agda.Utils.Monad (ifM)@@ -70,7 +65,7 @@ pure2 a = pure (a, a)  (<**>) :: Applicative f => f (a -> b, a -> b) -> f (a, a) -> f (b, b)-ff <**> xx = pure (uncurry (***)) <*> ff <*> xx+ff <**> xx = (uncurry (***)) <$> ff <*> xx  -- | Instantiate full as long as things are equal class SynEq a where@@ -79,7 +74,7 @@   synEq' a a' = ifEqual (uncurry synEq) (a, a')  instance SynEq Bool where-  synEq x y | x == y = return (x, y)+  synEq x y | x == y    = return (x, y)   synEq x y | otherwise = inequal (x, y)  -- | Syntactic term equality ignores 'DontCare' stuff.@@ -115,36 +110,19 @@     | n == n'   = Plus n <$$> synEq v v'     | otherwise = inequal (l, l') -instance SynEq LevelAtom where-  synEq l l' = do-    l  <- lift (unBlock =<< instantiate' l)-    case (l, l') of-      (MetaLevel m vs  , MetaLevel m' vs'  ) | m == m' -> MetaLevel m    <$$> synEq vs vs'-      (UnreducedLevel v, UnreducedLevel v' )           -> UnreducedLevel <$$> synEq v v'-      -- The reason for being blocked should not matter for equality.-      (NeutralLevel r v, NeutralLevel r' v')           -> NeutralLevel r <$$> synEq v v'-      (BlockedLevel m v, BlockedLevel m' v')           -> BlockedLevel m <$$> synEq v v'-      _ -> inequal (l, l')-    where-      unBlock l =-        case l of-          BlockedLevel m v ->-            ifM (isInstantiatedMeta m)-                (pure $ UnreducedLevel v)-                (pure l)-          _ -> pure l- instance SynEq Sort where   synEq s s' = do     (s, s') <- lift $ instantiate' (s, s')     case (s, s') of       (Type l  , Type l'   ) -> Type <$$> synEq l l'-      (PiSort a b, PiSort a' b') -> piSort <$$> synEq a a' <**> synEq' b b'+      (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       (Prop l  , Prop l'   ) -> Prop <$$> synEq l l'-      (Inf     , Inf       ) -> pure2 s+      (Inf f m , Inf f' n) | f == f', m == n -> pure2 s+      (SSet l  , SSet l'   ) -> SSet <$$> synEq l l'       (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')@@ -159,6 +137,9 @@     | length as == length as' = unzip <$> zipWithM synEq' as as'     | otherwise               = inequal (as, as') +instance (SynEq a, SynEq b) => SynEq (a,b) where+  synEq (a,b) (a',b') = (,) <$$> synEq a a' <**> synEq b b'+ instance SynEq a => SynEq (Elim' a) where   synEq e e' =     case (e, e') of@@ -168,7 +149,7 @@                           -> (IApply u v *** IApply u' v') <$> synEq r r'       _                   -> inequal (e, e') -instance (Subst t a, SynEq a) => SynEq (Abs a) where+instance (Subst a, SynEq a) => SynEq (Abs a) where   synEq a a' =     case (a, a') of       (NoAbs x b, NoAbs x' b') -> (NoAbs x *** NoAbs x') <$>  synEq b b'@@ -187,6 +168,6 @@     | otherwise = inequal (d, d')  instance SynEq ArgInfo where-  synEq ai@(ArgInfo h r o _) ai'@(ArgInfo h' r' o' _)-    | h == h', r == r' = pure2 ai+  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')

src/full/Agda/TypeChecking/Telescope.hs view

@@ -5,7 +5,7 @@  import Control.Monad -import Data.Foldable (forM_, find)+import Data.Foldable (find) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List@@ -23,6 +23,8 @@ import Agda.TypeChecking.Free import Agda.TypeChecking.Warnings +import Agda.Utils.CallStack ( withCallerCallStack )+import Agda.Utils.Empty import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Null@@ -36,7 +38,7 @@ import Agda.Utils.Impossible  -- | Flatten telescope: (Γ : Tel) -> [Type Γ]-flattenTel :: Subst Term a => Tele (Dom a) -> [Dom a]+flattenTel :: TermSubst a => Tele (Dom a) -> [Dom a] flattenTel EmptyTel          = [] flattenTel (ExtendTel a tel) = raise (size tel + 1) a : flattenTel (absBody tel) @@ -54,9 +56,7 @@     (i, _) `comesBefore` (_, a) = i `freeIn` unEl (unDom a) -- a tiny bit unsafe  reorderTel_ :: [Dom Type] -> Permutation-reorderTel_ tel = case reorderTel tel of-  Nothing -> __IMPOSSIBLE__-  Just p  -> p+reorderTel_ tel = fromMaybe __IMPOSSIBLE__ (reorderTel tel)  -- | Unflatten: turns a flattened telescope into a proper telescope. Must be --   properly ordered.@@ -66,7 +66,7 @@   where     tel' = unflattenTel xs tel     a'   = applySubst rho a-    rho  = parallelS (replicate (size tel + 1) (withFileAndLine impossibleTerm))+    rho  = parallelS (replicate (size tel + 1) (withCallerCallStack impossibleTerm)) unflattenTel [] (_ : _) = __IMPOSSIBLE__ unflattenTel (_ : _) [] = __IMPOSSIBLE__ @@ -147,14 +147,19 @@ 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 (flipP perm) $ flattenTel tel   in  unflattenTel names types  -- | 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 = allDependencies IntSet.empty+varDependencies tel = addLocks . allDependencies IntSet.empty   where+    addLocks s | IntSet.null s = s+               | otherwise = IntSet.union s $ IntSet.fromList $ filter (>= m) locks+      where+        locks = catMaybes [ deBruijnView (unArg a) | (a :: Arg Term) <- teleArgs tel, getLock a == IsLock]+        m = IntSet.findMin s     n  = size tel     ts = flattenTel tel @@ -219,7 +224,7 @@      perm  = Perm n $ map (n-1-) $ VarSet.toDescList is ++ VarSet.toDescList isC -    ts1   = renameP __IMPOSSIBLE__ (reverseP perm) (permute perm ts0)+    ts1   = renameP impossible (reverseP perm) (permute perm ts0)      tel'  = unflattenTel (permute perm names) ts1 @@ -243,9 +248,12 @@     checkDependencies soFar []     = True     checkDependencies soFar (j:js) = ok && checkDependencies (IntSet.insert j soFar) js       where-        fv' = allFreeVars $ indexWithDefault __IMPOSSIBLE__ ts0 (n-1-j)-        fv  = fv' `IntSet.intersection` IntSet.fromAscList [ 0 .. n-1 ]-        ok  = fv `IntSet.isSubsetOf` soFar+        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      ok    = all (<n) is && checkDependencies IntSet.empty is @@ -253,7 +261,7 @@      perm  = Perm n $ map (n-1-) $ is ++ isC -    ts1   = renameP __IMPOSSIBLE__ (reverseP perm) (permute perm ts0)+    ts1   = renameP impossible (reverseP perm) (permute perm ts0)      tel'  = unflattenTel (permute perm names) ts1 @@ -309,8 +317,8 @@     perm  = Perm n $ is    -- works on de Bruijn indices     rho   = reverseP perm  -- works on de Bruijn levels -    p1    = renameP __IMPOSSIBLE__ perm p -- Γ' ⊢ p1 : A'-    us    = map (\i -> fromMaybe p1 (deBruijnVar <$> List.findIndex (i ==) is)) [ 0 .. n-1 ]+    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)      ts1   = permute rho $ applyPatSubst sigma ts0@@ -327,13 +335,16 @@      , PatternSubstitution) -- Γ' ⊢ ρ : Γ expandTelescopeVar gamma k delta c = (tel', rho)   where-    (ts1,a:ts2) = fromMaybe __IMPOSSIBLE__ $+    (ts1,xa:ts2) = fromMaybe __IMPOSSIBLE__ $                     splitExactlyAt k $ telToList gamma+    a = raise (size delta) (snd <$> xa) -- Γ₁Δ ⊢ D pars -    cpi         = noConPatternInfo+    cpi         = ConPatternInfo       { conPInfo   = defaultPatternInfo       , conPRecord = True-      , conPType   = Just $ snd <$> argFromDom a+      , conPFallThrough+                   = False+      , conPType   = Just $ argFromDom a       , conPLazy   = True       }     cargs       = map (setOrigin Inserted) $ teleNamedArgs delta@@ -369,12 +380,12 @@   where     absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t -telViewPath :: Type -> TCM TelView+telViewPath :: PureTCM m => Type -> m TelView telViewPath = telViewUpToPath (-1)  -- | @telViewUpToPath n t@ takes off $t$ --   the first @n@ (or arbitrary many if @n < 0@) function domains or Path types.-telViewUpToPath :: Int -> Type -> TCM TelView+telViewUpToPath :: PureTCM m => Int -> Type -> m TelView telViewUpToPath 0 t = return $ TelV EmptyTel t telViewUpToPath n t = do   vt <- pathViewAsPi $ t@@ -394,7 +405,7 @@ -- by the Path types encountered. The boundary terms live in the -- telescope given by the @TelView@. -- Each point of the boundary has the type of the codomain of the Path type it got taken from, see @fullBoundary@.-telViewUpToPathBoundary' :: (MonadReduce m, HasBuiltins m) => Int -> Type -> m (TelView,Boundary)+telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView,Boundary) telViewUpToPathBoundary' 0 t = return $ (TelV EmptyTel t,[]) telViewUpToPathBoundary' n t = do   vt <- pathViewAsPi' $ t@@ -428,7 +439,7 @@ --  Output: ΔΓ ⊢ b --          ΔΓ ⊢ i : I --          ΔΓ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : b-telViewUpToPathBoundary :: (MonadReduce m, HasBuiltins m) => Int -> Type -> m (TelView,Boundary)+telViewUpToPathBoundary :: PureTCM m => Int -> Type -> m (TelView,Boundary) telViewUpToPathBoundary i a = do    (telv@(TelV tel b), bs) <- telViewUpToPathBoundary' i a    return $ (telv, fullBoundary tel bs)@@ -440,10 +451,10 @@ --          Δ.Γ ⊢ i : I --          Δ.Γ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : T -- Useful to reconstruct IApplyP patterns after teleNamedArgs Γ.-telViewUpToPathBoundaryP :: (MonadReduce m, HasBuiltins m) => Int -> Type -> m (TelView,Boundary)+telViewUpToPathBoundaryP :: PureTCM m => Int -> Type -> m (TelView,Boundary) telViewUpToPathBoundaryP = telViewUpToPathBoundary' -telViewPathBoundaryP :: (MonadReduce m, HasBuiltins m) => Type -> m (TelView,Boundary)+telViewPathBoundaryP :: PureTCM m => Type -> m (TelView,Boundary) telViewPathBoundaryP = telViewUpToPathBoundaryP (-1)  @@ -459,22 +470,20 @@   where     recurse = fmap updateArg     matchVar x =-      snd <$> flip find boundary (\case+      snd <$> find (\case         (Var i [],_) -> i == x-        _            -> __IMPOSSIBLE__)+        _            -> __IMPOSSIBLE__) boundary     updateArg a@(Arg info p) =       case deBruijnView p of         Just i | Just (t,u) <- matchVar i -> IApply t u p         _                                 -> Apply a  pathViewAsPi-  :: (MonadReduce m, HasBuiltins m)-  =>Type -> m (Either (Dom Type, Abs Type) Type)+  :: PureTCM m => Type -> m (Either (Dom Type, Abs Type) Type) pathViewAsPi t = either (Left . fst) Right <$> pathViewAsPi' t  pathViewAsPi'-  :: (MonadReduce m, HasBuiltins m)-  => Type -> m (Either ((Dom Type, Abs Type), (Term,Term)) Type)+  :: PureTCM m => Type -> m (Either ((Dom Type, Abs Type), (Term,Term)) Type) pathViewAsPi' t = do   pathViewAsPi'whnf <*> reduce t @@ -488,7 +497,7 @@     PathType s l p a x y | Just interval <- minterval ->       let name | Lam _ (Abs n _) <- unArg a = n                | otherwise = "i"-          i = El Inf interval+          i = El (SSet $ ClosedLevel 0) interval       in         Left $ ((defaultDom $ i, Abs name $ El (raise 1 s) $ raise 1 (unArg a) `apply` [defaultArg $ var 0]), (unArg x, unArg y)) @@ -496,7 +505,7 @@  -- | returns Left (a,b) in case the type is @Pi a b@ or @PathP b _ _@ --   assumes the type is in whnf.-piOrPath :: Type -> TCM (Either (Dom Type, Abs Type) Type)+piOrPath :: HasBuiltins m => Type -> m (Either (Dom Type, Abs Type) Type) piOrPath t = do   t <- pathViewAsPi'whnf <*> pure t   case t of@@ -520,8 +529,7 @@ telView'Path = telView'UpToPath (-1)  isPath-  :: (MonadReduce m, HasBuiltins m)-  => Type -> m (Maybe (Dom Type, Abs Type))+  :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type)) isPath t = either Just (const Nothing) <$> pathViewAsPi t  telePatterns :: DeBruijn a => Telescope -> Boundary -> [NamedArg (Pattern' a)]@@ -534,9 +542,9 @@   where     recurse = (fmap . fmap . fmap) updateVar     matchVar x =-      snd <$> flip find boundary (\case+      snd <$> find (\case         (Var i [],_) -> i == x-        _            -> __IMPOSSIBLE__)+        _            -> __IMPOSSIBLE__) boundary     updateVar x =       case deBruijnView x of         Just i | Just (t,u) <- matchVar i -> IApplyP defaultPatternInfo t u x@@ -545,7 +553,7 @@ -- | Decomposing a function type.  mustBePi :: MonadReduce m => Type -> m (Dom Type, Abs Type)-mustBePi t = ifNotPiType t __IMPOSSIBLE__ $ \ a b -> return (a,b)+mustBePi t = ifNotPiType t __IMPOSSIBLE__ $ curry return  -- | If the given type is a @Pi@, pass its parts to the first continuation. --   If not (or blocked), pass the reduced type to the second continuation.@@ -571,27 +579,30 @@ ifNotPiType :: MonadReduce m => Type -> (Type -> m a) -> (Dom Type -> Abs Type -> m a) -> m a ifNotPiType = flip . ifPiType -ifNotPiOrPathType :: (MonadReduce tcm, MonadTCM tcm) => Type -> (Type -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a+ifNotPiOrPathType :: (MonadReduce tcm, HasBuiltins tcm) => Type -> (Type -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a ifNotPiOrPathType t no yes = do-  ifPiType t yes (\ t -> either (uncurry yes . fst) (const $ no t) =<< (liftTCM pathViewAsPi'whnf <*> pure t))+  ifPiType t yes (\ t -> either (uncurry yes . fst) (const $ no t) =<< (pathViewAsPi'whnf <*> pure t))   -- | A safe variant of 'piApply'.  class PiApplyM a where-  piApplyM :: MonadReduce m => Type -> a -> m Type+  piApplyM' :: (MonadReduce m, HasBuiltins m) => m Empty -> Type -> a -> m Type +  piApplyM :: (MonadReduce m, HasBuiltins m) => Type -> a -> m Type+  piApplyM = piApplyM' __IMPOSSIBLE__+ instance PiApplyM Term where-  piApplyM t v = ifNotPiType t __IMPOSSIBLE__ {-else-} $ \ _ b -> return $ absApp b v+  piApplyM' err t v = ifNotPiOrPathType t (\_ -> absurd <$> err) {-else-} $ \ _ b -> return $ absApp b v  instance PiApplyM a => PiApplyM (Arg a) where-  piApplyM t = piApplyM t . unArg+  piApplyM' err t = piApplyM' err t . unArg  instance PiApplyM a => PiApplyM (Named n a) where-  piApplyM t = piApplyM t . namedThing+  piApplyM' err t = piApplyM' err t . namedThing  instance PiApplyM a => PiApplyM [a] where-  piApplyM t = foldl (\ mt v -> mt >>= (`piApplyM` v)) (return t)+  piApplyM' err t = foldl (\ mt v -> mt >>= \t -> (piApplyM' err t v)) (return t)   -- | Compute type arity@@ -609,7 +620,7 @@   = OutputTypeName QName   | OutputTypeVar   | OutputTypeVisiblePi-  | OutputTypeNameNotYetKnown+  | OutputTypeNameNotYetKnown Blocker   | NoOutputTypeName  -- | Strips all hidden and instance Pi's and return the argument@@ -617,7 +628,7 @@ getOutputTypeName :: Type -> TCM (Telescope, OutputTypeName) getOutputTypeName t = do   TelV tel t' <- telViewUpTo' (-1) notVisible t-  ifBlocked (unEl t') (\ _ _ -> return (tel , OutputTypeNameNotYetKnown)) $ \ _ v ->+  ifBlocked (unEl t') (\ b _ -> return (tel , OutputTypeNameNotYetKnown b)) $ \ _ v ->     case v of       -- Possible base types:       Def n _  -> return (tel , OutputTypeName n)@@ -639,7 +650,7 @@   (tel , n) <- getOutputTypeName t   case n of     OutputTypeName n -> addNamedInstance x n-    OutputTypeNameNotYetKnown -> addUnknownInstance x+    OutputTypeNameNotYetKnown{} -> addUnknownInstance x     NoOutputTypeName -> warning $ WrongInstanceDeclaration     OutputTypeVar -> warning $ WrongInstanceDeclaration     OutputTypeVisiblePi -> warning $ InstanceWithExplicitArg x

src/full/Agda/TypeChecking/Telescope.hs-boot view

@@ -5,10 +5,15 @@ import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Context (MonadAddContext)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Substitute+import Agda.Utils.Empty (Empty)  class PiApplyM a where-  piApplyM :: MonadReduce m => Type -> a -> m Type+  piApplyM' :: (MonadReduce m, HasBuiltins m) => m Empty -> Type -> a -> m Type++  piApplyM :: (MonadReduce m, HasBuiltins m) => Type -> a -> m Type+  piApplyM = piApplyM' __IMPOSSIBLE__  instance PiApplyM Term where instance PiApplyM a => PiApplyM (Arg a) where

src/full/Agda/TypeChecking/Telescope/Path.hs view

@@ -1,4 +1,4 @@-+{-# LANGUAGE NondecreasingIndentation #-} module Agda.TypeChecking.Telescope.Path where  import Prelude hiding (null)@@ -18,21 +18,22 @@ import Agda.TypeChecking.Telescope  import Agda.Utils.List+import Agda.Utils.Maybe import Agda.Utils.Size  import Agda.Utils.Impossible  --- | In an ambient context Γ, @telePiPath f Δ t bs@ builds a type that+-- | In an ambient context Γ, @telePiPath f lams Δ t bs@ builds a type that -- can be @telViewPathBoundaryP'ed@ into (TelV Δ t, bs'). --   Γ.Δ ⊢ t --   bs = [(i,u_i)] --   Δ = Δ0,(i : I),Δ1---   ∀ b ∈ {0,1}.  Γ.Δ0 | u_i .b : (telePiPath f Δ1 t bs)(i = b)+--   ∀ b ∈ {0,1}.  Γ.Δ0 | lams Δ1 (u_i .b) : (telePiPath f Δ1 t bs)(i = b) -- kinda: see lams --   Γ ⊢ telePiPath f Δ t bs-telePiPath :: (Abs Type -> Abs Type) -> Telescope -> Type -> Boundary -> TCM Type-telePiPath reAbs tel t bs = do-  pp <- primPathP+telePiPath :: (Abs Type -> Abs Type) -> ([Arg ArgName] -> Term -> Term) -> Telescope -> Type -> Boundary -> TCM Type+telePiPath reAbs lams tel t bs = do+  mpp <- getTerm' builtinPathP   io <- primIOne   let     argN = Arg defaultArgInfo@@ -51,25 +52,50 @@     telePiPath (x:xs) (ExtendTel a tel)       = case List.find (\ (t,_) -> t == var x) bs of           Just (_,u) -> do+            let pp = fromMaybe __IMPOSSIBLE__ mpp+            let names = teleArgNames $ unAbs tel             -- assume a = 𝕀             b <- b             l <- getLevel b             return $ El (Type l) $               pp `apply` [ argH (Level l)                          , argN (Lam defaultArgInfo (unEl <$> b))-                         , argN $ fst u-                         , argN $ snd u+                         , argN $ lams names (fst u)+                         , argN $ lams names (snd u)                          ]           Nothing    -> do             b <- b-            return $ El (piSort a (getSort <$> b)) (Pi a (reAbs b))+            return $ El (mkPiSort a b) (Pi a (reAbs b))       where         b  = traverse (telePiPath xs) tel     telePiPath _     EmptyTel = __IMPOSSIBLE__     telePiPath []    _        = __IMPOSSIBLE__   telePiPath (downFrom (size tel)) tel +-- | @telePiPath_ Δ t [(i,u)]@+--   Δ ⊢ t+--   i ∈ Δ+--   Δ ⊢ u_b : t  for  b ∈ {0,1}+telePiPath_ :: Telescope -> Type -> [(Int,(Term,Term))] -> TCM Type+telePiPath_ tel t bndry = do+  reportSDoc "tc.tel.path" 40                  $ text "tel  " <+> prettyTCM tel+  reportSDoc "tc.tel.path" 40 $ addContext tel $ text "type " <+> prettyTCM t+  reportSDoc "tc.tel.path" 40 $ addContext tel $ text "bndry" <+> pretty bndry +  telePiPath id argsLam tel t [(var i, u) | (i , u) <- bndry]+ where+   argsLam args tm = strengthenS impossible 1 `applySubst`+     foldr (\ Arg{argInfo = ai, unArg = x} -> Lam ai . Abs x) tm args++-- | arity of the type, including both Pi and Path.+--   Does not reduce the type.+arityPiPath :: Type -> TCM Int+arityPiPath t = do+  t' <- piOrPath t+  case t' of+    Left (_ , u) -> (+1) <$> arityPiPath (unAbs u)+    Right _ -> return 0+ iApplyVars :: DeBruijn a => [NamedArg (Pattern' a)] -> [Int] iApplyVars ps = flip concatMap (map namedArg ps) $ \case                              IApplyP _ t u x ->@@ -80,3 +106,12 @@                              DotP{} -> []                              DefP _ _ ps -> iApplyVars ps                              ConP _ _ ps -> iApplyVars ps++isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool+isInterval t = liftTCM $ do+  mi <- getName' builtinInterval+  caseMaybe mi (return False) $ \ i -> do+  t <- reduce $ unEl t+  case t of+    Def q [] -> return $ q == i+    _        -> return $ False

src/full/Agda/TypeChecking/Unquote.hs view

@@ -2,30 +2,39 @@ module Agda.TypeChecking.Unquote where  import Control.Arrow (first, second)-import Control.Monad.State+import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.State import Control.Monad.Writer hiding ((<>))  import Data.Char-import qualified Data.HashSet as HashSet+import Data.Map (Map)+import qualified Data.Map as Map import Data.Maybe (fromMaybe)-import Data.Traversable (traverse)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T import Data.Word -import Agda.Syntax.Common+import System.Process ( readProcessWithExitCode )+import System.Exit ( ExitCode(..) )++import Agda.Syntax.Common hiding ( Nat ) import Agda.Syntax.Internal as I import qualified Agda.Syntax.Reflected as R import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Literal import Agda.Syntax.Position-import Agda.Syntax.Fixity import Agda.Syntax.Info import Agda.Syntax.Translation.ReflectedToAbstract +import Agda.Interaction.Library ( ExeName )+import Agda.Interaction.Options ( optTrustedExecutables, optAllowExec )+ import Agda.TypeChecking.Constraints-import Agda.TypeChecking.MetaVars.Mention import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Free import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute@@ -34,21 +43,18 @@ import Agda.TypeChecking.Conversion import Agda.TypeChecking.EtaContract import Agda.TypeChecking.Primitive+import Agda.TypeChecking.ReconstructParameters+import Agda.TypeChecking.CheckInternal  import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Rules.Def -import Agda.Utils.Except-  ( mkExceptT-  , MonadError(catchError, throwError)-  , ExceptT-  , runExceptT-  ) import Agda.Utils.Either import Agda.Utils.Lens+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Monad import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.String ( Str(Str), unStr ) import qualified Agda.Interaction.Options.Lenses as Lens  import Agda.Utils.Impossible@@ -77,7 +83,7 @@ unpackUnquoteM m cxt s = runExceptT $ runWriterT $ runStateT (runReaderT m cxt) s  packUnquoteM :: (Context -> UnquoteState -> TCM (UnquoteRes a)) -> UnquoteM a-packUnquoteM f = ReaderT $ \ cxt -> StateT $ \ s -> WriterT $ mkExceptT $ f cxt s+packUnquoteM f = ReaderT $ \ cxt -> StateT $ \ s -> WriterT $ ExceptT $ f cxt s  runUnquoteM :: UnquoteM a -> TCM (Either UnquoteError (a, [QName])) runUnquoteM m = do@@ -112,11 +118,11 @@                     _ -> return False  isDef :: QName -> TCM Term -> UnquoteM Bool-isDef f tm = do-  t <- liftTCM $ etaContract =<< normalise =<< tm-  case t of-    Def g _ -> return (f == g)-    _       -> return False+isDef f tm = loop <$> liftTCM tm+  where+    loop (Def g _) = f == g+    loop (Lam _ b) = loop $ unAbs b+    loop _         = False  reduceQuotedTerm :: Term -> UnquoteM Term reduceQuotedTerm t = do@@ -140,7 +146,7 @@  ensureDef :: QName -> UnquoteM QName ensureDef x = do-  i <- either (const Axiom) theDef <$> getConstInfo' x  -- for recursive unquoteDecl+  i <- either (const defaultAxiom) theDef <$> getConstInfo' x  -- for recursive unquoteDecl   case i of     Constructor{} -> do       def <- liftTCM $ prettyTCM =<< primAgdaTermDef@@ -150,7 +156,7 @@  ensureCon :: QName -> UnquoteM QName ensureCon x = do-  i <- either (const Axiom) theDef <$> getConstInfo' x  -- for recursive unquoteDecl+  i <- either (const defaultAxiom) theDef <$> getConstInfo' x  -- for recursive unquoteDecl   case i of     Constructor{} -> return x     _ -> do@@ -163,22 +169,47 @@   case a of     R.Pi{}   -> "f"     R.Sort{} -> "A"-    R.Def d _ | c:_ <- show (qnameName d),-              isAlpha c -> [toLower c]+    R.Def d _+      | c : cs  <- prettyShow (qnameName d),+        Just lc <- reallyToLower c,+        not (null cs) || isUpper c -> [lc]     _        -> "_"+  where+    -- Heuristic (see #5048 for some discussion):+    -- If first character can be `toLower`ed use that, unless the name has only one character and is+    -- already lower case. (to avoid using the same name for the type and the bound variable).+    reallyToLower c+      | toUpper lc /= lc = Just lc+      | otherwise        = Nothing+      where lc = toLower c --- TODO: reflect Quantity, Cohesion+-- TODO: reflect Cohesion instance Unquote Modality where-  unquote t = (\ r -> Modality r defaultQuantity defaultCohesion) <$> unquote t+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [r,q] <- allApplyElims es ->+        choice+          [(c `isCon` primModalityConstructor,+              Modality <$> unquoteN r+                       <*> unquoteN q+                       <*> pure defaultCohesion)]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "modality" t  instance Unquote ArgInfo where   unquote t = do     t <- reduceQuotedTerm t     case t of-      Con c _ es | Just [h,r] <- allApplyElims es ->+      Con c _ es | Just [h,m] <- allApplyElims es ->         choice           [(c `isCon` primArgArgInfo,-              ArgInfo <$> unquoteN h <*> unquoteN r <*> pure Reflected <*> pure unknownFreeVariables)]+              ArgInfo <$> unquoteN h+                      <*> unquoteN m+                      <*> pure Reflected+                      <*> pure unknownFreeVariables+                      <*> pure defaultAnnotation)]           __IMPOSSIBLE__       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "arg info" t@@ -213,42 +244,42 @@   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitNat _ n) -> return n+      Lit (LitNat n) -> return n       _ -> throwError $ NonCanonical "integer" t  instance Unquote Word64 where   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitWord64 _ n) -> return n+      Lit (LitWord64 n) -> return n       _ -> throwError $ NonCanonical "word64" t  instance Unquote Double where   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitFloat _ x) -> return x+      Lit (LitFloat x) -> return x       _ -> throwError $ NonCanonical "float" t  instance Unquote Char where   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitChar _ x) -> return x+      Lit (LitChar x) -> return x       _ -> throwError $ NonCanonical "char" t -instance Unquote Str where+instance Unquote Text where   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitString _ x) -> return (Str x)+      Lit (LitString x) -> return x       _ -> throwError $ NonCanonical "string" t  unquoteString :: Term -> UnquoteM String-unquoteString x = unStr <$> unquote x+unquoteString x = T.unpack <$> unquote x -unquoteNString :: Arg Term -> UnquoteM String-unquoteNString x = unStr <$> unquoteN x+unquoteNString :: Arg Term -> UnquoteM Text+unquoteNString = unquoteN  data ErrorPart = StrPart String | TermPart A.Expr | NamePart QName @@ -257,12 +288,31 @@   prettyTCM (TermPart t) = prettyTCM t   prettyTCM (NamePart x) = prettyTCM x +-- | We do a little bit of work here to make it possible to generate nice+--   layout for multi-line error messages. Specifically we split the parts+--   into lines (indicated by \n in a string part) and vcat all the lines.+prettyErrorParts :: [ErrorPart] -> TCM Doc+prettyErrorParts = vcat . map (hcat . map prettyTCM) . splitLines+  where+    splitLines [] = []+    splitLines (StrPart s : ss) =+      case break (=='\n') s of+        (s0, '\n' : s1) -> [StrPart s0] : splitLines (StrPart s1 : ss)+        (s0, "")        -> consLine (StrPart s0) (splitLines ss)+        _               -> __IMPOSSIBLE__+    splitLines (p@TermPart{} : ss) = consLine p (splitLines ss)+    splitLines (p@NamePart{} : ss) = consLine p (splitLines ss)++    consLine l []        = [[l]]+    consLine l (l' : ls) = (l : l') : ls++ instance Unquote ErrorPart where   unquote t = do     t <- reduceQuotedTerm t     case t of       Con c _ es | Just [x] <- allApplyElims es ->-        choice [ (c `isCon` primAgdaErrorPartString, StrPart  <$> unquoteNString x)+        choice [ (c `isCon` primAgdaErrorPartString, StrPart . T.unpack <$> unquoteNString x)                , (c `isCon` primAgdaErrorPartTerm,   TermPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Term)))                , (c `isCon` primAgdaErrorPartName,   NamePart <$> unquoteN x) ]                __IMPOSSIBLE__@@ -283,6 +333,17 @@       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "list" t +instance (Unquote a, Unquote b) => Unquote (a, b) where+  unquote t = do+    t <- reduceQuotedTerm t+    SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+    case t of+      Con c _ es | Just [x,y] <- allApplyElims es ->+        choice+          [(pure (c == sigmaCon), (,) <$> unquoteN x <*> unquoteN y)]+          __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "pair" t+ instance Unquote Hiding where   unquote t = do     t <- reduceQuotedTerm t@@ -308,12 +369,24 @@       Con c _ vs -> __IMPOSSIBLE__       _        -> throwError $ NonCanonical "relevance" t +instance Unquote Quantity where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice+          [(c `isCon` primQuantityω, return $ Quantityω QωInferred)+          ,(c `isCon` primQuantity0, return $ Quantity0 Q0Inferred)]+          __IMPOSSIBLE__+      Con c _ vs -> __IMPOSSIBLE__+      _        -> throwError $ NonCanonical "quantity" t+ instance Unquote QName where   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitQName _ x) -> return x-      _                  -> throwError $ NonCanonical "name" t+      Lit (LitQName x) -> return x+      _ -> throwError $ NonCanonical "name" t  instance Unquote a => Unquote (R.Abs a) where   unquote t = do@@ -321,7 +394,7 @@     case t of       Con c _ es | Just [x,y] <- allApplyElims es ->         choice-          [(c `isCon` primAbsAbs, R.Abs <$> (hint <$> unquoteNString x) <*> unquoteN y)]+          [(c `isCon` primAbsAbs, R.Abs <$> (hint . T.unpack <$> unquoteNString x) <*> unquoteN y)]           __IMPOSSIBLE__       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "abstraction" t@@ -333,7 +406,7 @@   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitMeta r f x) -> liftTCM $ do+      Lit (LitMeta f x) -> liftTCM $ do         live <- (f ==) <$> getCurrentPath         unless live $ do             m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f@@ -356,8 +429,12 @@           __IMPOSSIBLE__       Con c _ es | Just [u] <- allApplyElims es ->         choice-          [(c `isCon` primAgdaSortSet, R.SetS <$> unquoteN u)-          ,(c `isCon` primAgdaSortLit, R.LitS <$> unquoteN u)]+          [ (c `isCon` primAgdaSortSet, R.SetS <$> unquoteN u)+          , (c `isCon` primAgdaSortLit, R.LitS <$> unquoteN u)+          , (c `isCon` primAgdaSortProp, R.PropS <$> unquoteN u)+          , (c `isCon` primAgdaSortPropLit, R.PropLitS <$> unquoteN u)+          , (c `isCon` primAgdaSortInf, R.InfS <$> unquoteN u)+          ]           __IMPOSSIBLE__       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "sort" t@@ -365,18 +442,15 @@ instance Unquote Literal where   unquote t = do     t <- reduceQuotedTerm t-    let litMeta r x = do-          file <- getCurrentPath-          return $ LitMeta r file x     case t of       Con c _ es | Just [x] <- allApplyElims es ->         choice-          [ (c `isCon` primAgdaLitNat,    LitNat    noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitFloat,  LitFloat  noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitChar,   LitChar   noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitString, LitString noRange <$> unquoteNString x)-          , (c `isCon` primAgdaLitQName,  LitQName  noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitMeta,   litMeta   noRange =<< unquoteN x) ]+          [ (c `isCon` primAgdaLitNat,    LitNat    <$> unquoteN x)+          , (c `isCon` primAgdaLitFloat,  LitFloat  <$> unquoteN x)+          , (c `isCon` primAgdaLitChar,   LitChar   <$> unquoteN x)+          , (c `isCon` primAgdaLitString, LitString <$> unquoteNString x)+          , (c `isCon` primAgdaLitQName,  LitQName  <$> unquoteN x)+          , (c `isCon` primAgdaLitMeta,   LitMeta   <$> getCurrentPath <*> unquoteN x) ]           __IMPOSSIBLE__       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "literal" t@@ -393,7 +467,8 @@       Con c _ es | Just [x] <- allApplyElims es ->         choice           [ (c `isCon` primAgdaTermSort,      R.Sort      <$> unquoteN x)-          , (c `isCon` primAgdaTermLit,       R.Lit       <$> unquoteN x) ]+          , (c `isCon` primAgdaTermLit,       R.Lit       <$> unquoteN x)+          ]           __IMPOSSIBLE__        Con c _ es | Just [x, y] <- allApplyElims es ->@@ -404,7 +479,8 @@           , (c `isCon` primAgdaTermMeta,    R.Meta    <$> unquoteN x <*> unquoteN y)           , (c `isCon` primAgdaTermLam,     R.Lam     <$> unquoteN x <*> unquoteN y)           , (c `isCon` primAgdaTermPi,      mkPi      <$> unquoteN x <*> unquoteN y)-          , (c `isCon` primAgdaTermExtLam,  R.ExtLam  <$> unquoteN x <*> unquoteN y) ]+          , (c `isCon` primAgdaTermExtLam,  R.ExtLam  <$> (List1.fromList <$> unquoteN x) <*> unquoteN y)+          ]           __IMPOSSIBLE__         where           mkPi :: Dom R.Type -> R.Abs R.Type -> R.Term@@ -423,16 +499,13 @@   unquote t = do     t <- reduceQuotedTerm t     case t of-      Con c _ [] ->-        choice-          [ (c `isCon` primAgdaPatAbsurd, return R.AbsurdP)-          , (c `isCon` primAgdaPatDot,    return R.DotP)-          ] __IMPOSSIBLE__       Con c _ es | Just [x] <- allApplyElims es ->         choice-          [ (c `isCon` primAgdaPatVar,  R.VarP  <$> unquoteNString x)-          , (c `isCon` primAgdaPatProj, R.ProjP <$> unquoteN x)-          , (c `isCon` primAgdaPatLit,  R.LitP  <$> unquoteN x) ]+          [ (c `isCon` primAgdaPatVar,    R.VarP    . fromInteger <$> unquoteN x)+          , (c `isCon` primAgdaPatAbsurd, R.AbsurdP . fromInteger <$> unquoteN x)+          , (c `isCon` primAgdaPatDot,    R.DotP  <$> unquoteN x)+          , (c `isCon` primAgdaPatProj,   R.ProjP <$> unquoteN x)+          , (c `isCon` primAgdaPatLit,    R.LitP  <$> unquoteN x) ]           __IMPOSSIBLE__       Con c _ es | Just [x, y] <- allApplyElims es ->         choice@@ -445,13 +518,13 @@   unquote t = do     t <- reduceQuotedTerm t     case t of-      Con c _ es | Just [x] <- allApplyElims es ->+      Con c _ es | Just [x, y] <- allApplyElims es ->         choice-          [ (c `isCon` primAgdaClauseAbsurd, R.AbsurdClause <$> unquoteN x) ]+          [ (c `isCon` primAgdaClauseAbsurd, R.AbsurdClause <$> unquoteN x <*> unquoteN y) ]           __IMPOSSIBLE__-      Con c _ es | Just [x, y] <- allApplyElims es ->+      Con c _ es | Just [x, y, z] <- allApplyElims es ->         choice-          [ (c `isCon` primAgdaClauseClause, R.Clause <$> unquoteN x <*> unquoteN y) ]+          [ (c `isCon` primAgdaClauseClause, R.Clause <$> unquoteN x <*> unquoteN y <*> unquoteN z) ]           __IMPOSSIBLE__       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "clause" t@@ -494,7 +567,9 @@              , (f `isDef` primAgdaTCMCheckType,  tcFun2 tcCheckType  u v)              , (f `isDef` primAgdaTCMDeclareDef, uqFun2 tcDeclareDef u v)              , (f `isDef` primAgdaTCMDeclarePostulate, uqFun2 tcDeclarePostulate u v)-             , (f `isDef` primAgdaTCMDefineFun,  uqFun2 tcDefineFun  u v) ]+             , (f `isDef` primAgdaTCMDefineFun,  uqFun2 tcDefineFun  u v)+             , (f `isDef` primAgdaTCMQuoteOmegaTerm, tcQuoteTerm (unElim v))+             ]              failEval     I.Def f [l, a, u] ->       choice [ (f `isDef` primAgdaTCMReturn,      return (unElim u))@@ -504,14 +579,19 @@              , (f `isDef` primAgdaTCMBlockOnMeta, uqFun1 tcBlockOnMeta u)              , (f `isDef` primAgdaTCMDebugPrint,  tcFun3 tcDebugPrint l a u)              , (f `isDef` primAgdaTCMNoConstraints, tcNoConstraints (unElim u))+             , (f `isDef` primAgdaTCMWithReconsParams, tcWithReconsParams (unElim u))              , (f `isDef` primAgdaTCMRunSpeculative, tcRunSpeculative (unElim u))+             , (f `isDef` primAgdaTCMExec, tcFun3 tcExec l a u)              ]              failEval     I.Def f [_, _, u, v] ->       choice [ (f `isDef` primAgdaTCMCatchError,    tcCatchError    (unElim u) (unElim v))              , (f `isDef` primAgdaTCMWithNormalisation, tcWithNormalisation (unElim u) (unElim v))              , (f `isDef` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v))-             , (f `isDef` primAgdaTCMInContext,     tcInContext     (unElim u) (unElim v)) ]+             , (f `isDef` primAgdaTCMInContext,     tcInContext     (unElim u) (unElim v))+             , (f `isDef` primAgdaTCMOnlyReduceDefs, tcOnlyReduceDefs (unElim u) (unElim v))+             , (f `isDef` primAgdaTCMDontReduceDefs, tcDontReduceDefs (unElim u) (unElim v))+             ]              failEval     I.Def f [_, _, _, _, m, k] ->       choice [ (f `isDef` primAgdaTCMBind, tcBind (unElim m) (unElim k)) ]@@ -528,7 +608,7 @@       if norm then normalise v else instantiateFull v      mkT l a = El s a-      where s = Type $ Max 0 [Plus 0 $ UnreducedLevel l]+      where s = Type $ atomicLevel l      -- Don't catch Unquote errors!     tcCatchError :: Term -> Term -> UnquoteM Term@@ -540,6 +620,18 @@       v <- unquote b       liftU1 (locallyTC eUnquoteNormalise $ const v) (evalTCM m) +    tcOnlyReduceDefs = tcDoReduceDefs OnlyReduceDefs+    tcDontReduceDefs = tcDoReduceDefs DontReduceDefs++    tcWithReconsParams :: Term -> UnquoteM Term+    tcWithReconsParams m = liftU1 locallyReconstructed $ evalTCM m++    tcDoReduceDefs :: (Set QName -> ReduceDefs) -> Term -> Term -> UnquoteM Term+    tcDoReduceDefs reduceDefs v m = do+      qs <- unquote v+      let defs = reduceDefs $ Set.fromList qs+      liftU1 (locallyTC eReduceDefs (<> defs)) (evalTCM m)+     uqFun1 :: Unquote a => (a -> UnquoteM b) -> Elim -> UnquoteM b     uqFun1 fun a = do       a <- unquote (unElim a)@@ -567,22 +659,22 @@     tcFun3 :: (Unquote a, Unquote b, Unquote c) => (a -> b -> c -> TCM d) -> Elim -> Elim -> Elim -> UnquoteM d     tcFun3 fun = uqFun3 (\ x y z -> liftTCM (fun x y z)) -    tcFreshName :: Str -> TCM Term+    tcFreshName :: Text -> TCM Term     tcFreshName s = do       m <- currentModule-      quoteName . qualify m <$> freshName_ (unStr s)+      quoteName . qualify m <$> freshName_ (T.unpack s)      tcUnify :: R.Term -> R.Term -> TCM Term     tcUnify u v = do-      (u, a) <- inferExpr        =<< toAbstract_ u-      v      <- flip checkExpr a =<< toAbstract_ v+      (u, a) <- locallyReduceAllDefs $ inferExpr        =<< toAbstract_ u+      v      <- locallyReduceAllDefs $ flip checkExpr a =<< toAbstract_ v       equalTerm a u v       primUnitUnit      tcBlockOnMeta :: MetaId -> UnquoteM Term     tcBlockOnMeta x = do       s <- gets snd-      throwError (BlockedOnMeta s x)+      throwError (BlockedOnMeta s $ unblockOnMeta x)      tcCommit :: UnquoteM Term     tcCommit = do@@ -594,11 +686,11 @@       liftTCM primUnitUnit      tcTypeError :: [ErrorPart] -> TCM a-    tcTypeError err = typeError . GenericDocError =<< fsep (map prettyTCM err)+    tcTypeError err = typeError . GenericDocError =<< prettyErrorParts err -    tcDebugPrint :: Str -> Integer -> [ErrorPart] -> TCM Term-    tcDebugPrint (Str s) n msg = do-      reportSDoc s (fromIntegral n) $ fsep (map prettyTCM msg)+    tcDebugPrint :: Text -> Integer -> [ErrorPart] -> TCM Term+    tcDebugPrint s n msg = do+      reportSDoc (T.unpack s) (fromIntegral n) $ prettyErrorParts msg       primUnitUnit      tcNoConstraints :: Term -> UnquoteM Term@@ -606,15 +698,29 @@      tcInferType :: R.Term -> TCM Term     tcInferType v = do+      r <- isReconstructed       (_, a) <- inferExpr =<< toAbstract_ v-      quoteType =<< process a+      if r then do+        a <- process a+        a <- locallyReduceAllDefs $ reconstructParametersInType a+        reportSDoc "tc.reconstruct" 50 $ "Infer after reconstruct:"+          <+> pretty a+        locallyReconstructed (quoteType a)+      else+        quoteType =<< process a      tcCheckType :: R.Term -> R.Type -> TCM Term     tcCheckType v a = do-      a <- isType_ =<< toAbstract_ a+      r <- isReconstructed+      a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a       e <- toAbstract_ v       v <- checkExpr e a-      quoteTerm =<< process v+      if r then do+        v <- process v+        v <- locallyReduceAllDefs $ reconstructParameters' defaultAction a v+        locallyReconstructed (quoteTerm v)+      else+        quoteTerm =<< process v      tcQuoteTerm :: Term -> UnquoteM Term     tcQuoteTerm v = liftTCM $ quoteTerm =<< process v@@ -626,29 +732,64 @@      tcNormalise :: R.Term -> TCM Term     tcNormalise v = do-      (v, _) <- inferExpr =<< toAbstract_ v-      quoteTerm =<< normalise v+      r <- isReconstructed+      (v, t) <- locallyReduceAllDefs $ inferExpr  =<< toAbstract_ v+      if r then do+        v <- normalise v+        t <- normalise t+        v <- locallyReduceAllDefs $ reconstructParameters' defaultAction t v+        reportSDoc "tc.reconstruct" 50 $ "Normalise reconstruct:" <+> pretty v+        locallyReconstructed $ quoteTerm v+      else+       quoteTerm =<< normalise v      tcReduce :: R.Term -> TCM Term     tcReduce v = do-      (v, _) <- inferExpr =<< toAbstract_ v-      quoteTerm =<< reduce =<< instantiateFull v+      r <- isReconstructed+      (v, t) <- locallyReduceAllDefs $ inferExpr =<< toAbstract_ v+      if r then do+        v <- reduce =<< instantiateFull v+        t <- reduce =<< instantiateFull t+        v <- locallyReduceAllDefs $ reconstructParameters' defaultAction t v+        reportSDoc "tc.reconstruct" 50 $ "Reduce reconstruct:" <+> pretty v+        locallyReconstructed $ quoteTerm v+      else+        quoteTerm =<< reduce =<< instantiateFull v      tcGetContext :: UnquoteM Term     tcGetContext = liftTCM $ do+      r <- isReconstructed       as <- map (fmap snd) <$> getContext       as <- etaContract =<< process as-      buildList <*> mapM quoteDom as+      if r then do+         as <- recons (reverse as)+         let as' = reverse as+         locallyReconstructed $ buildList <*> mapM quoteDom as'+      else+         buildList <*> mapM quoteDom as+      where+         recons :: [Dom Type] -> TCM [Dom Type]+         recons [] = return []+         recons (d@Dom {unDom=t} : ds) = do+           t <- locallyReduceAllDefs $ reconstructParametersInType t+           let d' = d{unDom=t}+           ds' <- addContext d' $ recons ds+           return $ d' : ds'      extendCxt :: Arg R.Type -> UnquoteM a -> UnquoteM a     extendCxt a m = do-      a <- liftTCM $ traverse (isType_ <=< toAbstract_) a-      liftU1 (addContext (domFromArg a :: Dom Type)) m+      a <- locallyReduceAllDefs $ liftTCM $ traverse (isType_ <=< toAbstract_) a+      liftU1 (addContext ("x" :: String, domFromArg a :: Dom Type)) m      tcExtendContext :: Term -> Term -> UnquoteM Term     tcExtendContext a m = do       a <- unquote a-      strengthen __UNREACHABLE__ <$> extendCxt a (evalTCM $ raise 1 m)+      fmap (strengthen impossible) $ extendCxt a $ do+        v <- evalTCM $ raise 1 m+        when (freeIn 0 v) $ liftTCM $ genericDocError =<<+          hcat ["Local variable '", prettyTCM (var 0), "' escaping in result of extendContext:"]+            <?> prettyTCM v+        return v      tcInContext :: Term -> Term -> UnquoteM Term     tcInContext c m = do@@ -664,8 +805,17 @@       where err _ = genericError $ "Unbound name: " ++ prettyShow x      tcGetType :: QName -> TCM Term-    tcGetType x = quoteType . defType =<< constInfo x+    tcGetType x = do+      r  <- isReconstructed+      ci <- constInfo x+      let t = defType ci+      if r then do+        t <- locallyReduceAllDefs $ reconstructParametersInType t+        quoteType t+      else+        quoteType t +     tcIsMacro :: QName -> TCM Term     tcIsMacro x = do       true  <- primTrue@@ -675,15 +825,55 @@       qBool . isMacro . theDef <$> constInfo x      tcGetDefinition :: QName -> TCM Term-    tcGetDefinition x = quoteDefn =<< constInfo x+    tcGetDefinition x = do+      r <- isReconstructed+      if r then+        tcGetDefinitionRecons x+      else+        quoteDefn =<< constInfo x +    tcGetDefinitionRecons :: QName -> TCM Term+    tcGetDefinitionRecons x = do+      ci@(Defn {theDef=d}) <- constInfo x+      case d of+        f@(Function {funClauses=cs}) -> do+          cs' <- mapM reconsClause cs+          locallyReconstructed $ quoteDefn ci{theDef=f{funClauses=cs'}}++        _ -> quoteDefn ci++      where+        reconsClause :: Clause -> TCM Clause+        reconsClause c = do+          tel' <- reconsTel $ clauseTel c+          b' <- case (clauseType c, clauseBody c) of+                (Just t, Just b) ->+                  addContext (clauseTel c) $ do+                     bb <- locallyReduceAllDefs+                           $ reconstructParameters' defaultAction (unArg t) b+                     return $ Just bb+                _ -> return $ clauseBody c+          let c' = c{clauseBody=b', clauseTel=tel'}+          reportSDoc "tc.reconstruct" 50+                   $ "getDefinition reconstructed clause:" <+> pretty c'+          return c'++        reconsTel :: Telescope -> TCM Telescope+        reconsTel EmptyTel = return EmptyTel+        reconsTel (ExtendTel _ NoAbs{}) = __IMPOSSIBLE__+        reconsTel (ExtendTel (d@Dom{unDom=t}) ds@Abs{unAbs=ts}) = do+           t <- locallyReduceAllDefs $ reconstructParametersInType t+           let d' = d{unDom=t}+           ts' <- addContext d' $ reconsTel ts+           return $ ExtendTel d' ds{unAbs=ts'}++     setDirty :: UnquoteM ()     setDirty = modify (first $ const Dirty)      tcDeclareDef :: Arg QName -> R.Type -> UnquoteM Term     tcDeclareDef (Arg i x) a = inOriginalContext $ do       setDirty-      let r = getRelevance i       when (hidden i) $ liftTCM $ typeError . GenericDocError =<<         "Cannot declare hidden function" <+> prettyTCM x       tell [x]@@ -692,7 +882,7 @@           [ "declare" <+> prettyTCM x <+> ":"           , nest 2 $ prettyR a           ]-        a <- isType_ =<< toAbstract_ a+        a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a         alreadyDefined <- isRight <$> getConstInfo' x         when alreadyDefined $ genericError $ "Multiple declarations of " ++ prettyShow x         addConstant x $ defaultDefn i x a emptyFunction@@ -705,7 +895,6 @@       when (Lens.getSafeMode clo) $ liftTCM $ typeError . GenericDocError =<<         "Cannot postulate '" <+> prettyTCM x <+> ":" <+> prettyR a <+> "' with safe flag"       setDirty-      let r = getRelevance i       when (hidden i) $ liftTCM $ typeError . GenericDocError =<<         "Cannot declare hidden function" <+> prettyTCM x       tell [x]@@ -714,10 +903,10 @@           [ "declare Postulate" <+> prettyTCM x <+> ":"           , nest 2 $ prettyR a           ]-        a <- isType_ =<< toAbstract_ a+        a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a         alreadyDefined <- isRight <$> getConstInfo' x         when alreadyDefined $ genericError $ "Multiple declarations of " ++ prettyShow x-        addConstant x $ defaultDefn i x a Axiom+        addConstant x $ defaultDefn i x a defaultAxiom         when (isInstance i) $ addTypedInstance x a         primUnitUnit @@ -730,7 +919,7 @@       let accessDontCare = __IMPOSSIBLE__  -- or ConcreteDef, value not looked at       ac <- asksTC (^. lensIsAbstract)     -- Issue #4012, respect AbstractMode       let i = mkDefInfo (nameConcrete $ qnameName x) noFixity' accessDontCare ac noRange-      checkFunDef NotDelayed i x cs+      locallyReduceAllDefs $ checkFunDef NotDelayed i x cs       primUnitUnit      tcRunSpeculative :: Term -> UnquoteM Term@@ -743,3 +932,55 @@           return x         _ -> liftTCM $ typeError . GenericDocError =<<           "Should be a pair: " <+> prettyTCM u+++------------------------------------------------------------------------+-- * Trusted executables+------------------------------------------------------------------------++type ExeArg  = Text+type StdIn   = Text+type StdOut  = Text+type StdErr  = Text++-- | Raise an error if the @--allow-exec@ option was not specified.+--+requireAllowExec :: TCM ()+requireAllowExec = do+  allowExec <- optAllowExec <$> pragmaOptions+  unless allowExec $+    typeError $ GenericError "Missing option --allow-exec"++-- | Convert an @ExitCode@ to an Agda natural number.+--+exitCodeToNat :: ExitCode -> Nat+exitCodeToNat  ExitSuccess    = Nat 0+exitCodeToNat (ExitFailure n) = Nat (toInteger n)++-- | Call a trusted executable with the given arguments and input.+--+--   Returns the exit code, stdout, and stderr.+--+tcExec :: ExeName -> [ExeArg] -> StdIn -> TCM Term+tcExec exe args stdIn = do+  requireAllowExec+  exes <- optTrustedExecutables <$> commandLineOptions+  case Map.lookup exe exes of+    Nothing -> raiseExeNotFound exe exes+    Just fp -> do+      let strArgs    = T.unpack <$> args+      let strStdIn   = T.unpack stdIn+      (datExitCode, strStdOut, strStdErr) <- lift $ readProcessWithExitCode fp strArgs strStdIn+      let natExitCode = exitCodeToNat datExitCode+      let txtStdOut   = T.pack strStdOut+      let txtStdErr   = T.pack strStdErr+      toR <- toTerm+      return $ toR (natExitCode, (txtStdOut, txtStdErr))++-- | Raise an error if the trusted executable cannot be found.+--+raiseExeNotFound :: ExeName -> Map ExeName FilePath -> TCM a+raiseExeNotFound exe exes = genericDocError =<< do+  vcat . map pretty $+    ("Could not find '" ++ T.unpack exe ++ "' in list of trusted executables:") :+    [ "  - " ++ T.unpack exe | exe <- Map.keys exes ]

src/full/Agda/TypeChecking/Warnings.hs view

@@ -1,8 +1,10 @@+ module Agda.TypeChecking.Warnings   ( MonadWarning(..)   , genericWarning   , genericNonFatalError-  , warning_, warning, warnings+  , warning'_, warning_, warning', warning, warnings+  , raiseWarningsOnUsage   , isUnsolvedWarning   , isMetaWarning   , isMetaTCWarning@@ -14,22 +16,28 @@   , runPM   ) where -import qualified Data.Set as Set-import qualified Data.List as List-import Data.Maybe ( catMaybes )-import Data.Semigroup ( Semigroup, (<>) )- import Control.Monad ( forM, unless )+import Control.Monad.Except import Control.Monad.Reader ( ReaderT ) import Control.Monad.State ( StateT ) import Control.Monad.Trans ( lift ) +import qualified Data.List as List+import qualified Data.Map  as Map+import qualified Data.Set  as Set+import Data.Maybe     ( catMaybes )+import Data.Semigroup ( Semigroup, (<>) )+ import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Caching import {-# SOURCE #-} Agda.TypeChecking.Pretty (MonadPretty, prettyTCM) import {-# SOURCE #-} Agda.TypeChecking.Pretty.Call-import {-# SOURCE #-} Agda.TypeChecking.Pretty.Warning ()+import {-# SOURCE #-} Agda.TypeChecking.Pretty.Warning ( prettyWarning )+import {-# SOURCE #-} Agda.TypeChecking.Monad.Pure +import Agda.Syntax.Abstract.Name ( QName )+import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Parser @@ -37,30 +45,27 @@ import Agda.Interaction.Options.Warnings import {-# SOURCE #-} Agda.Interaction.Highlighting.Generate (highlightWarning) +import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) import Agda.Utils.Lens import qualified Agda.Utils.Pretty as P-import Agda.Utils.Except -class (MonadPretty m, MonadError TCErr m) => MonadWarning m where-  -- | Render the warning-  addWarning :: TCWarning -> m ()+import Agda.Utils.Impossible -instance Applicative m => Semigroup (ReaderT s m P.Doc) where-  d1 <> d2 = (<>) <$> d1 <*> d2 -instance MonadWarning m => MonadWarning (ReaderT r m) where-  addWarning = lift . addWarning+-- * The warning monad+--------------------------------------------------------------------------- -instance Monad m => Semigroup (StateT s m P.Doc) where-  d1 <> d2 = (<>) <$> d1 <*> d2+class (MonadPretty m, MonadError TCErr m) => MonadWarning m where+  -- | Store a warning and generate highlighting from it.+  addWarning :: TCWarning -> m () -instance MonadWarning m => MonadWarning (StateT s m) where+  default addWarning+    :: (MonadWarning n, MonadTrans t, t n ~ m)+    => TCWarning -> m ()   addWarning = lift . addWarning --- This instance is more specific than a generic instance--- @Semigroup a => Semigroup (TCM a)@-instance {-# OVERLAPPING #-} Semigroup (TCM P.Doc) where-  d1 <> d2 = (<>) <$> d1 <*> d2+instance MonadWarning m => MonadWarning (ReaderT r m)+instance MonadWarning m => MonadWarning (StateT s m)  instance MonadWarning TCM where   addWarning tcwarn = do@@ -73,6 +78,9 @@         | onlyOnce w && elem tcwarn tcwarns = tcwarns -- Eq on TCWarning only checks head constructor         | otherwise                         = tcwarn : tcwarns +-- * Raising warnings+---------------------------------------------------------------------------+ {-# SPECIALIZE genericWarning :: P.Doc -> TCM () #-} genericWarning :: MonadWarning m => P.Doc -> m () genericWarning = warning . GenericWarning@@ -81,9 +89,9 @@ genericNonFatalError :: MonadWarning m => P.Doc -> m () genericNonFatalError = warning . GenericNonFatalError -{-# SPECIALIZE warning_ :: Warning -> TCM TCWarning #-}-warning_ :: MonadWarning m => Warning -> m TCWarning-warning_ w = do+{-# SPECIALIZE warning'_ :: CallStack -> Warning -> TCM TCWarning #-}+warning'_ :: (MonadWarning m) => CallStack -> Warning -> m TCWarning+warning'_ loc w = do   r <- viewTC eRange   c <- viewTC eCall   b <- areWeCaching@@ -91,9 +99,13 @@   -- issues (but we might need to keep the overall range `r` for   -- comparing ranges)   let r' = case w of { NicifierIssue{} -> NoRange ; _ -> r }-  p <- sayWhen r' c $ prettyTCM w-  return $ TCWarning r w p b+  p <- sayWhen r' c $ prettyWarning w+  return $ TCWarning loc r w p b +{-# SPECIALIZE warning_ :: Warning -> TCM TCWarning #-}+warning_ :: (HasCallStack, MonadWarning m) => Warning -> m TCWarning+warning_ = withCallerCallStack . flip warning'_+ -- UNUSED Liang-Ting Chen 2019-07-16 ---- | @applyWarningMode@ filters out the warnings the user has not requested ---- Users are not allowed to ignore non-fatal errors.@@ -103,9 +115,9 @@ --  ErrorWarnings -> Just w --  AllWarnings   -> w <$ guard (Set.member (warningName w) $ wm ^. warningSet) -{-# SPECIALIZE warnings :: [Warning] -> TCM () #-}-warnings :: MonadWarning m => [Warning] -> m ()-warnings ws = do+{-# SPECIALIZE warnings' :: CallStack -> [Warning] -> TCM () #-}+warnings' :: MonadWarning m => CallStack -> [Warning] -> m ()+warnings' loc ws = do    wmode <- optWarningMode <$> pragmaOptions @@ -113,23 +125,44 @@   -- or not. If we find one which should be turned into an error, we keep processing   -- the rest of the warnings and *then* report all of the errors at once.   merrs <- forM ws $ \ w' -> do-    tcwarn <- warning_ w'+    tcwarn <- warning'_ loc w'     if wmode ^. warn2Error && warningName w' `elem` wmode ^. warningSet     then pure (Just tcwarn)     else Nothing <$ addWarning tcwarn    let errs = catMaybes merrs-  unless (null errs) $ typeError $ NonFatalErrors errs+  unless (null errs) $ typeError' loc $ NonFatalErrors errs -{-# SPECIALIZE warning :: Warning -> TCM () #-}-warning :: MonadWarning m => Warning -> m ()-warning = warnings . pure+{-# SPECIALIZE warnings :: HasCallStack => [Warning] -> TCM () #-}+warnings :: (HasCallStack, MonadWarning m) => [Warning] -> m ()+warnings = withCallerCallStack . flip warnings' +{-# SPECIALIZE warning' :: CallStack -> Warning -> TCM () #-}+warning' :: MonadWarning m => CallStack -> Warning -> m ()+warning' loc = warnings' loc . pure++{-# SPECIALIZE warning :: HasCallStack => Warning -> TCM () #-}+warning :: (HasCallStack, MonadWarning m) => Warning -> m ()+warning = withCallerCallStack . flip warning'++-- | Raise every 'WARNING_ON_USAGE' connected to a name.+{-# SPECIALIZE raiseWarningsOnUsage :: QName -> TCM () #-}+raiseWarningsOnUsage :: (MonadWarning m, ReadTCState 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+  reportSLn "scope.warning.usage" 50 $ "Checking usage of " ++ P.prettyShow d+  mapM_ (warning . UserWarning) =<< Map.lookup d <$> getUserWarnings+++-- * Classifying warnings+---------------------------------------------------------------------------+ isUnsolvedWarning :: Warning -> Bool isUnsolvedWarning w = warningName w `Set.member` unsolvedWarnings  isMetaWarning :: Warning -> Bool-isMetaWarning w = case w of+isMetaWarning = \case    UnsolvedInteractionMetas{} -> True    UnsolvedMetaVariables{}    -> True    _                          -> False@@ -177,6 +210,9 @@     partite = (< AllWarnings) . classifyWarning . tcWarning     (errors, warnings) = List.partition partite ws ++-- * Warnings in the parser+---------------------------------------------------------------------------  -- | running the Parse monad

− src/full/Agda/TypeChecking/Warnings.hs-boot

@@ -1,13 +0,0 @@--module Agda.TypeChecking.Warnings where--import Agda.TypeChecking.Monad.Base--import Agda.Utils.Except--class (MonadPretty m, MonadError TCErr m) => MonadWarning m where-  addWarning :: TCWarning -> m ()--warnings :: MonadWarning m => [Warning] -> m ()--warning :: MonadWarning m => Warning -> m ()

src/full/Agda/TypeChecking/With.hs view

@@ -7,11 +7,8 @@  import Data.Either import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Foldable ( foldrM )-import Data.Traversable ( traverse )  import Agda.Syntax.Common import Agda.Syntax.Internal as I@@ -29,9 +26,11 @@ import Agda.TypeChecking.Free import Agda.TypeChecking.Patterns.Abstract import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive ( getRefl ) import Agda.TypeChecking.Records import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path  import Agda.TypeChecking.Abstract import Agda.TypeChecking.Rules.LHS.Implicit@@ -39,6 +38,7 @@  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 (empty)@@ -75,13 +75,13 @@   -- Input:   :: Telescope                         -- ^ __@Δ@__             context of types and with-arguments.   -> Type                              -- ^ __@Δ ⊢ t@__         type of rhs.-  -> [WithHiding (Term, EqualityView)] -- ^ __@Δ ⊢ vs : as@__   with arguments and their types.+  -> [Arg (Term, EqualityView)]        -- ^ __@Δ ⊢ vs : as@__   with arguments and their types.   -- Output:   -> ( Telescope                         -- @Δ₁@             part of context needed for with arguments and their types.      , Telescope                         -- @Δ₂@             part of context not needed for with arguments and their types.      , Permutation                       -- @π@              permutation from Δ to Δ₁Δ₂ as returned by 'splitTelescope'.      , Type                              -- @Δ₁Δ₂ ⊢ t'@      type of rhs under @π@-     , [WithHiding (Term, EqualityView)] -- @Δ₁ ⊢ vs' : as'@ with- and rewrite-arguments and types under @π@.+     , [Arg (Term, EqualityView)]        -- @Δ₁ ⊢ vs' : as'@ with- and rewrite-arguments and types under @π@.      )              -- ^ (__@Δ₁@__,__@Δ₂@__,__@π@__,__@t'@__,__@vtys'@__) where -- --   [@Δ₁@]        part of context needed for with arguments and their types.@@ -101,9 +101,9 @@     SplitTel delta1 delta2 perm = splitTelescope fv delta      -- Δ₁Δ₂ ⊢ π : Δ-    pi = renaming __IMPOSSIBLE__ (reverseP perm)+    pi = renaming impossible (reverseP perm)     -- Δ₁ ⊢ ρ : Δ₁Δ₂  (We know that as does not depend on Δ₂.)-    rho = strengthenS __IMPOSSIBLE__ $ size delta2+    rho = strengthenS impossible $ size delta2     -- Δ₁ ⊢ ρ ∘ π : Δ     rhopi = composeS rho pi @@ -121,16 +121,17 @@  withFunctionType   :: Telescope                          -- ^ @Δ₁@                        context for types of with types.-  -> [WithHiding (Term, EqualityView)]  -- ^ @Δ₁,Δ₂ ⊢ vs : raise Δ₂ as@  with and rewrite-expressions and their type.+  -> [Arg (Term, EqualityView)]         -- ^ @Δ₁,Δ₂ ⊢ vs : raise Δ₂ as@  with and rewrite-expressions and their type.   -> Telescope                          -- ^ @Δ₁ ⊢ Δ₂@                   context extension to type with-expressions.   -> Type                               -- ^ @Δ₁,Δ₂ ⊢ b@                 type of rhs.+  -> [(Int,(Term,Term))]                -- ^ @Δ₁,Δ₂ ⊢ [(i,(u0,u1))] : b  boundary.   -> TCM (Type, Nat)     -- ^ @Δ₁ → wtel → Δ₂′ → b′@ such that     --     @[vs/wtel]wtel = as@ and     --     @[vs/wtel]Δ₂′ = Δ₂@ and     --     @[vs/wtel]b′ = b@.     -- Plus the final number of with-arguments.-withFunctionType delta1 vtys delta2 b = addContext delta1 $ do+withFunctionType delta1 vtys delta2 b bndry = addContext delta1 $ do    reportSLn "tc.with.abstract" 20 $ "preparing for with-abstraction" @@ -138,7 +139,7 @@   -- of the pattern variables not mentioned in @vs : as@.   let dbg n s x = reportSDoc "tc.with.abstract" n $ nest 2 $ text (s ++ " =") <+> prettyTCM x -  let d2b = telePi_ delta2 b+  d2b <- telePiPath_ delta2 b bndry   dbg 30 "Δ₂ → B" d2b   d2b  <- normalise d2b   dbg 30 "normal Δ₂ → B" d2b@@ -151,20 +152,40 @@   wd2b <- foldrM piAbstract d2b vtys   dbg 30 "wΓ → Δ₂ → B" wd2b -  return (telePi_ delta1 wd2b, countWithArgs (map (snd . whThing) vtys))+  let nwithargs = countWithArgs (map (snd . unArg) vtys) +  TelV wtel _ <- telViewUpTo nwithargs wd2b++  -- select the boundary for "Δ₁" abstracting over "wΓ.Δ₂"+  let bndry' = [(i - sd2,(lams u0, lams u1)) | (i,(u0,u1)) <- bndry, i >= sd2]+        where sd2 = size delta2+              lams u = teleNoAbs wtel (abstract delta2 u)++  d1wd2b <- telePiPath_ delta1 wd2b bndry'++  dbg 30 "Δ₁ → wΓ → Δ₂ → B" d1wd2b++  return (d1wd2b, nwithargs)+ countWithArgs :: [EqualityView] -> Nat countWithArgs = sum . map countArgs   where     countArgs OtherType{}    = 1+    countArgs IdiomType{}    = 2     countArgs EqualityType{} = 2  -- | From a list of @with@ and @rewrite@ expressions and their types, --   compute the list of final @with@ expressions (after expanding the @rewrite@s).-withArguments :: [WithHiding (Term, EqualityView)] -> [WithHiding Term]-withArguments vtys = flip concatMap vtys $ traverse $ \case-  (v, OtherType a) -> [v]-  (prf, eqt@(EqualityType s _eq _pars _t v _v')) -> [unArg v, prf]+withArguments :: [Arg (Term, EqualityView)] ->+                 TCM [Arg Term]+withArguments vtys = do+  tss <- forM vtys $ \ (Arg info ts) -> fmap (map (Arg info)) $ case ts of+    (v, OtherType a) -> pure [v]+    (prf, eqt@(EqualityType s _eq _pars _t v _v')) -> pure [unArg v, prf]+    (v, IdiomType t) -> do+       mkRefl <- getRefl+       pure [v, mkRefl (defaultArg v)]+  pure (concat tss)  -- | Compute the clauses for the with-function given the original patterns. buildWithFunction@@ -191,8 +212,10 @@             where             fromWithP (A.WithP _ p) = p             fromWithP _ = __IMPOSSIBLE__-      reportSDoc "tc.with" 50 $ "inheritedPats:" <+> vcat [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a-                                                               | A.ProblemEq p v a <- inheritedPats ]+      reportSDoc "tc.with" 50 $ "inheritedPats:" <+> vcat+        [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a+        | A.ProblemEq p v a <- inheritedPats+        ]       (strippedPats, ps') <- stripWithClausePatterns cxtNames f aux t delta qs npars perm ps       reportSDoc "tc.with" 50 $ hang "strippedPats:" 2 $                                   vcat [ prettyA p <+> "==" <+> prettyTCM v <+> (":" <+> prettyTCM t)@@ -343,14 +366,14 @@     setVarArgInfo x p = setOrigin (getOrigin p) $ setArgInfo (varArgInfo x) p      strip-      :: Term                         -- ^ Self.-      -> Type                         -- ^ The type to be eliminated.-      -> [NamedArg A.Pattern]       -- ^ With-clause patterns.-      -> [NamedArg DeBruijnPattern] -- ^ Parent-clause patterns with de Bruijn indices relative to Δ.+      :: Term                         -- Self.+      -> Type                         -- The type to be eliminated.+      -> [NamedArg A.Pattern]         -- With-clause patterns.+      -> [NamedArg DeBruijnPattern]   -- Parent-clause patterns with de Bruijn indices relative to Δ.       -> WriterT [ProblemEq] TCM [NamedArg A.Pattern]-            -- ^ With-clause patterns decomposed by parent-clause patterns.-            --   Also outputs named dot patterns from the parent clause that-            --   we need to add let-bindings for.+            -- With-clause patterns decomposed by parent-clause patterns.+            -- Also outputs named dot patterns from the parent clause that+            -- we need to add let-bindings for.      -- Case: out of with-clause patterns.     strip self t [] qs@(_ : _) = do@@ -428,20 +451,25 @@         VarP _ x  ->           (setVarArgInfo x p :) <$> recurse (var (dbPatVarIndex x)) -        IApplyP{}  -> typeError $ GenericError $ "with clauses not supported in the presence of Path patterns" -- TODO maybe we can support them now?+        IApplyP _ _ _ x  ->+          (setVarArgInfo x p :) <$> recurse (var (dbPatVarIndex x))+         DefP{}  -> typeError $ GenericError $ "with clauses not supported in the presence of hcomp patterns" -- TODO this should actually be impossible -        DotP o v  -> do+        DotP i v  -> do           (a, _) <- mustBePi t           tell [ProblemEq (namedArg p) v a]-          (makeImplicitP p :) <$> recurse v+          case v of+            Var x [] | PatOVar{} <- patOrigin i+               -> (p :) <$> recurse (var x)+            _  -> (makeWildP p :) <$> recurse v          q'@(ConP c ci qs') -> do          reportSDoc "tc.with.strip" 60 $            "parent pattern is constructor " <+> prettyTCM c          (a, b) <- mustBePi t          -- The type of the current pattern is a datatype.-         Def d es <- liftTCM $ normalise (unEl $ unDom a)+         Def d es <- liftTCM $ reduce (unEl $ unDom a)          let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es          -- Get the original constructor and field names.          c <- either __IMPOSSIBLE__ (`withRangeOf` c) <$> do liftTCM $ getConForm $ conName c@@ -459,8 +487,8 @@                 -- If dot-pattern is an application of the constructor, try to preserve the                 -- arguments.                 Application (A.Con (A.AmbQ cs')) es -> do-                  cs' <- liftTCM $ snd . partitionEithers <$> mapM getConForm (NonEmpty.toList cs')-                  unless (elem c cs') mismatch+                  cs' <- liftTCM $ List1.rights <$> mapM getConForm cs'+                  unless (c `elem` 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'@@ -487,13 +515,13 @@             -- 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 $ snd . partitionEithers <$> mapM getConForm (NonEmpty.toList cs')-            unless (elem c cs') mismatch+            cs' <- liftTCM $ List1.rights <$> mapM getConForm cs'+            unless (c `elem` cs') 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 $ insertMissingFields d (const $ A.WildP empty) fs+            ps' <- liftTCM $ insertMissingFieldsFail d (const $ A.WildP empty) fs                                                  (map argFromDom $ recordFieldNames def)             stripConP d us b c ConORec qs' ps' @@ -508,8 +536,8 @@            mismatch          LitP _ lit -> case namedArg p of-          A.LitP lit' | lit == lit' -> recurse $ Lit lit-          A.WildP{}                 -> recurse $ Lit lit+          A.LitP _ lit' | lit == lit' -> recurse $ Lit lit+          A.WildP{}                   -> recurse $ Lit lit            p@(A.PatternSynP pi' c' [ps']) -> do              reportSDoc "impossible" 10 $@@ -519,13 +547,18 @@           _ -> mismatch       where         recurse v = do-          caseMaybeM (liftTCM $ isPath t) (return ()) $ \ _ ->-            typeError $ GenericError $-              "With-clauses currently not supported under Path abstraction."+          -- caseMaybeM (liftTCM $ isPath t) (return ()) $ \ _ ->+          --   typeError $ GenericError $+          --     "With-clauses currently not supported under Path abstraction." -          t' <- piApplyM t v-          strip (self `apply1` v) t' ps qs+          let piOrPathApplyM t v = do+                (TelV tel t', bs) <- telViewUpToPathBoundaryP 1 t+                unless (size tel == 1) $ __IMPOSSIBLE__+                return (teleElims tel bs, subst 0 v t')+          (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 $           WithClausePatternMismatch (namedArg p0) q         mismatchOrigin o o' = addContext delta . typeError . GenericDocError =<< fsep@@ -540,28 +573,20 @@         prettyProjOrigin ProjPostfix = "a postfix projection"         prettyProjOrigin ProjSystem  = __IMPOSSIBLE__ -        -- | Make an ImplicitP, keeping arg. info.-        makeImplicitP :: NamedArg A.Pattern -> NamedArg A.Pattern-        makeImplicitP = updateNamedArg $ const $ A.WildP patNoRange+        -- Make a WildP, keeping arg. info.+        makeWildP :: NamedArg A.Pattern -> NamedArg A.Pattern+        makeWildP = updateNamedArg $ const $ A.WildP patNoRange          -- case I.ConP / A.ConP         stripConP-          :: QName-             -- ^ Data type name of this constructor pattern.-          -> [Arg Term]-             -- ^ Data type arguments of this constructor pattern.-          -> Abs Type-             -- ^ Type the remaining patterns eliminate.-          -> ConHead-             -- ^ Constructor of this pattern.-          -> ConInfo-             -- ^ Constructor info of this pattern (constructor/record).-          -> [NamedArg DeBruijnPattern]-             -- ^ Argument patterns (parent clause).-          -> [NamedArg A.Pattern]-             -- ^ Argument patterns (with clause).-          -> WriterT [ProblemEq] TCM [NamedArg A.Pattern]-             -- ^ Stripped patterns.+          :: QName       -- Data type name of this constructor pattern.+          -> [Arg Term]  -- Data type arguments of this constructor pattern.+          -> Abs Type    -- Type the remaining patterns eliminate.+          -> ConHead     -- Constructor of this pattern.+          -> ConInfo     -- Constructor info of this pattern (constructor/record).+          -> [NamedArg DeBruijnPattern]  -- Argument patterns (parent clause).+          -> [NamedArg A.Pattern]        -- Argument patterns (with clause).+          -> WriterT [ProblemEq] TCM [NamedArg A.Pattern]  -- Stripped patterns.         stripConP d us b c ci qs' ps' = do            -- Get the type and number of parameters of the constructor.@@ -662,7 +687,7 @@    -- Build the lhs of the display form and finish.   -- @var 0@ is the pattern variable (hole).-  let display = Display arity (replicate arity $ Apply $ defaultArg $ var 0) dt+  let display = Display arity [Apply $ defaultArg $ var i | i <- downFrom arity] dt    -- Debug printing.   let addFullCtx = addContext delta1@@ -697,7 +722,7 @@     -- Andreas, 2015-10-28: Yes, but properly! (Issue 1407)     sub top ys wild = parallelS $ map term [0 .. m + top - 1]       where-        term i = maybe wild var $ List.findIndex (Just i ==) ys+        term i = maybe wild var $ List.elemIndex (Just i) ys  -- Andreas, 2014-12-05 refactored using numberPatVars -- Andreas, 2013-02-28 modeled after Coverage/Match/buildMPatterns@@ -713,15 +738,28 @@     toTerms = map $ fmap $ toTerm . namedThing      toTerm :: DeBruijnPattern -> DisplayTerm-    toTerm p = case p of+    toTerm p = case patOrigin $ fromMaybe __IMPOSSIBLE__ $ patternInfo p of+      PatOSystem -> toDisplayPattern p+      PatOSplit  -> toDisplayPattern p+      PatOVar{}  -> toVarOrDot p+      PatODot    -> DDot $ patternToTerm p+      PatOWild   -> toVarOrDot p+      PatOCon    -> toDisplayPattern p+      PatORec    -> toDisplayPattern p+      PatOLit    -> toDisplayPattern p+      PatOAbsurd -> toDisplayPattern p -- see test/Succeed/Issue2849.agda++    toDisplayPattern :: DeBruijnPattern -> DisplayTerm+    toDisplayPattern = \case       IApplyP _ _ _ x -> DTerm $ var $ dbPatVarIndex x -- TODO, should be an Elim' DisplayTerm ?-      ProjP _ d   -> DDef d [] -- WRONG. TODO: convert spine to non-spine ... DDef d . defaultArg-      VarP i x -> case patOrigin i of-        PatODot -> DDot  $ var $ dbPatVarIndex x-        _       -> DTerm  $ var $ dbPatVarIndex x-      DotP i t -> case patOrigin i of-        PatOVar{} | Var i [] <- t -> DTerm t-        _                         -> DDot   $ t-      ConP c cpi ps -> DCon c (fromConPatternInfo cpi) $ toTerms ps-      LitP _ l    -> DTerm  $ Lit l+      ProjP _ d  -> __IMPOSSIBLE__+      VarP i x -> DTerm  $ var $ dbPatVarIndex x+      DotP i t -> DDot   $ t+      p@(ConP c cpi ps) -> DCon c (fromConPatternInfo cpi) $ toTerms ps+      LitP i l -> DTerm  $ Lit l       DefP _ q ps -> DDef q $ map Apply $ toTerms ps++    toVarOrDot :: DeBruijnPattern -> DisplayTerm+    toVarOrDot p = case patternToTerm p of+      Var i [] -> DTerm $ var i+      t        -> DDot t

src/full/Agda/Utils/Applicative.hs view

@@ -1,11 +1,20 @@ module Agda.Utils.Applicative        ( (?*>)        , (?$>)+       , foldA+       , foldMapA+       , forA        )        where  import Control.Applicative+import Data.Monoid ( Alt(..) )+import Data.Traversable ( for ) +-- | Better name for 'for'.+forA :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)+forA = for+ -- | Guard: return the action @f@ only if the boolean is @True@ (?*>) :: Alternative f => Bool -> f a -> f a b ?*> f = if b then f else empty@@ -13,3 +22,12 @@ -- | Guard: return the value @a@ only if the boolean is @True@ (?$>) :: Alternative f => Bool -> a -> f a b ?$> a = b ?*> pure a++-- | Branch over a 'Foldable' collection of values.+foldA :: (Alternative f, Foldable t) => t a -> f a+foldA = foldMapA pure++-- | Branch over a 'Foldable' collection of values using the supplied+--   action.+foldMapA :: (Alternative f, Foldable t) => (a -> f b) -> t a -> f b+foldMapA f = getAlt . foldMap (Alt . f)

src/full/Agda/Utils/Bag.hs view

@@ -7,7 +7,6 @@  import Text.Show.Functions () -- instance only -import Data.Foldable (Foldable(foldMap)) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map@@ -52,7 +51,8 @@ -- | @(bag ! a)@ finds all elements equal to @a@.  O(log n). --   Total function, returns @[]@ if none are. (!) :: Ord a => Bag a -> a -> [a]-Bag b ! a = Map.findWithDefault [] a b+(!) (Bag b) a = Map.findWithDefault [] a b+  -- Note: not defined infix because of BangPatterns.  -- | O(log n). member :: Ord a => a -> Bag a -> Bool

src/full/Agda/Utils/Benchmark.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE UndecidableInstances      #-}  -- | Tools for benchmarking and accumulating results. --   Nothing Agda-specific in here.@@ -8,19 +6,24 @@  import Prelude hiding (null) +import Control.DeepSeq import qualified Control.Exception as E (evaluate)+import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.Writer import Control.Monad.State -import Data.Foldable (foldMap)  import Data.Function import qualified Data.List as List import Data.Monoid import Data.Maybe +import GHC.Generics (Generic)+ import qualified Text.PrettyPrint.Boxes as Boxes +import Agda.Utils.ListT import Agda.Utils.Null import Agda.Utils.Monad hiding (finally) import qualified Agda.Utils.Maybe.Strict as Strict@@ -41,6 +44,7 @@ type Timings        a = Trie a CPUTime  data BenchmarkOn a = BenchmarkOff | BenchmarkOn | BenchmarkSome (Account a -> Bool)+  deriving Generic  isBenchmarkOn :: Account a -> BenchmarkOn a -> Bool isBenchmarkOn _ BenchmarkOff      = False@@ -57,6 +61,7 @@   , timings        :: !(Timings a)     -- ^ The accounts and their accumulated timing bill.   }+  deriving Generic  -- | Initial benchmark structure (empty). instance Null (Benchmark a) where@@ -123,16 +128,14 @@  -- | Monad with access to benchmarking data. -class (Ord a, Functor m, MonadIO m) => MonadBench a m | m -> a where-  getBenchmark :: m (Benchmark a)--  getsBenchmark :: (Benchmark a -> c) -> m c-  getsBenchmark f = f <$> getBenchmark+class (Ord (BenchPhase m), Functor m, MonadIO m) => MonadBench m where+  type BenchPhase m+  getBenchmark :: m (Benchmark (BenchPhase m)) -  putBenchmark :: Benchmark a -> m ()+  putBenchmark :: Benchmark (BenchPhase m) -> m ()   putBenchmark b = modifyBenchmark $ const b -  modifyBenchmark :: (Benchmark a -> Benchmark a) -> m ()+  modifyBenchmark :: (Benchmark (BenchPhase m) -> Benchmark (BenchPhase m)) -> m ()   modifyBenchmark f = do     b <- getBenchmark     putBenchmark $! f b@@ -140,33 +143,61 @@   -- | We need to be able to terminate benchmarking in case of an exception.   finally :: m b -> m c -> m b --- needs UndecidableInstances because of weakness of FunctionalDependencies-instance MonadBench a m => MonadBench a (ReaderT r m) where+getsBenchmark :: MonadBench m => (Benchmark (BenchPhase m) -> c) -> m c+getsBenchmark f = f <$> getBenchmark++instance MonadBench m => MonadBench (ReaderT r m) where+  type BenchPhase (ReaderT r m) = BenchPhase m   getBenchmark    = lift $ getBenchmark   putBenchmark    = lift . putBenchmark   modifyBenchmark = lift . modifyBenchmark   finally m f = ReaderT $ \ r ->     finally (m `runReaderT` r) (f `runReaderT` r) -instance MonadBench a m => MonadBench a (StateT r m) where+instance (MonadBench m, Monoid w) => MonadBench (WriterT w m) where+  type BenchPhase (WriterT w m) = BenchPhase m   getBenchmark    = lift $ getBenchmark   putBenchmark    = lift . putBenchmark   modifyBenchmark = lift . modifyBenchmark+  finally m f = WriterT $ finally (runWriterT m) (runWriterT f)++instance MonadBench m => MonadBench (StateT r m) where+  type BenchPhase (StateT r m) = BenchPhase m++  getBenchmark    = lift $ getBenchmark+  putBenchmark    = lift . putBenchmark+  modifyBenchmark = lift . modifyBenchmark   finally m f = StateT $ \s ->     finally (m `runStateT` s) (f `runStateT` s) +instance MonadBench m => MonadBench (ExceptT e m) where+  type BenchPhase (ExceptT e m) = BenchPhase m++  getBenchmark    = lift $ getBenchmark+  putBenchmark    = lift . putBenchmark+  modifyBenchmark = lift . modifyBenchmark+  finally m f = ExceptT $ finally (runExceptT m) (runExceptT f)++instance MonadBench m => MonadBench (ListT m) where+  type BenchPhase (ListT m) = BenchPhase m++  getBenchmark    = lift getBenchmark+  putBenchmark    = lift . putBenchmark+  modifyBenchmark = lift . modifyBenchmark+  finally m f = ListT $ finally (runListT m) (runListT f)+ -- | Turn benchmarking on/off. -setBenchmarking :: MonadBench a m => BenchmarkOn a -> m ()+setBenchmarking :: MonadBench m => BenchmarkOn (BenchPhase m) -> m () setBenchmarking b = modifyBenchmark $ mapBenchmarkOn $ const b  -- | Bill current account with time up to now. --   Switch to new account. --   Return old account (if any). -switchBenchmarking :: MonadBench a m-  => Strict.Maybe (Account a)      -- ^ Maybe new account.-  -> m (Strict.Maybe (Account a))  -- ^ Maybe old account.+switchBenchmarking :: MonadBench m+  => Strict.Maybe (Account (BenchPhase m))      -- ^ Maybe new account.+  -> m (Strict.Maybe (Account (BenchPhase m)))  -- ^ Maybe old account. switchBenchmarking newAccount = do   now <- liftIO $ getCPUTime   -- Stop and bill current benchmarking.@@ -179,7 +210,7 @@  -- | Resets the account and the timing information. -reset :: MonadBench a m => m ()+reset :: MonadBench m => m () reset = modifyBenchmark $   mapCurrentAccount (const Strict.Nothing) .   mapTimings (const Trie.empty)@@ -187,7 +218,7 @@ -- | Bill a computation to a specific account. --   Works even if the computation is aborted by an exception. -billTo :: MonadBench a m => Account a -> m c -> m c+billTo :: MonadBench m => Account (BenchPhase m) -> m c -> m c billTo account m = ifNotM (isBenchmarkOn account <$> getsBenchmark benchmarkOn) m $ do   -- Switch to new account.   old <- switchBenchmarking $ Strict.Just account@@ -195,7 +226,7 @@   (liftIO . E.evaluate =<< m) `finally` switchBenchmarking old  -- | Bill a CPS function to an account. Can't handle exceptions.-billToCPS :: MonadBench a m => Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c+billToCPS :: MonadBench m => Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c billToCPS account f k = ifNotM (isBenchmarkOn account <$> getsBenchmark benchmarkOn) (f k) $ do   -- Switch to new account.   old <- switchBenchmarking $ Strict.Just account@@ -204,5 +235,10 @@     k x  -- | Bill a pure computation to a specific account.-billPureTo :: MonadBench a m  => Account a -> c -> m c+billPureTo :: MonadBench m  => Account (BenchPhase m) -> c -> m c billPureTo account = billTo account . return++-- NFData instances.++instance NFData a => NFData (BenchmarkOn a)+instance NFData a => NFData (Benchmark a)

src/full/Agda/Utils/BiMap.hs view

@@ -1,68 +1,439 @@---- | Finite bijections (implemented as a pair of tree maps).+-- | Partly invertible finite maps.+--+-- Time complexities are given under the assumption that all relevant+-- instance functions, as well as arguments of function type, take+-- constant time, and "n" is the number of keys involved in the+-- operation.  module Agda.Utils.BiMap where -import Prelude hiding (lookup, unzip)-+import Prelude hiding (null, lookup) +import Control.Monad.Identity+import Control.Monad.State  import Data.Function- import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe+import Data.Ord+import Data.Tuple +import GHC.Generics (Generic) --- | Finite bijective map from @a@ to @b@.  There, and back again.-data BiMap a b = BiMap-  { biMapThere :: Map a b-  , biMapBack  :: Map b a+import Agda.Utils.List+import Agda.Utils.Null++-- | Partial injections from a type to some tag type.+--+-- The idea is that 'tag' should be injective on its domain: if+-- @'tag' x = 'tag' y = 'Just' i@, then @x = y@. However, this+-- property does not need to hold globally. The preconditions of the+-- 'BiMap' operations below specify for which sets of values 'tag'+-- must be injective.++class HasTag a where+  type Tag a+  tag :: a -> Maybe (Tag a)++-- | Checks if the function 'tag' is injective for the values in the+-- given list for which the function is defined.++tagInjectiveFor ::+  (Eq v, Eq (Tag v), HasTag v) =>+  [v] -> Bool+tagInjectiveFor vs = and+  [ v1 == v2+  | v1 <- vs+  , v2 <- vs+  , isJust (tag v1)+  , tag v1 == tag v2+  ]++-- | Finite maps from @k@ to @v@, with a way to quickly get from @v@+-- to @k@ for certain values of type @v@ (those for which 'tag' is+-- defined).+--+-- Every value of this type must satisfy 'biMapInvariant'.++data BiMap k v = BiMap+  { biMapThere :: Map k v+  , biMapBack  :: Map (Tag v) k   }+  deriving Generic +-- | The invariant for 'BiMap'.++biMapInvariant ::+  (Eq k, Eq v, Ord (Tag v), HasTag v) =>+  BiMap k v -> Bool+biMapInvariant m@(BiMap t u) =+  u ==+  Map.fromList+    [ (k', k)+    | (k, v) <- Map.toList t+    , Just k' <- [tag v]+    ]+    &&+  tagInjectiveFor (map snd $ toList m)++instance Null (BiMap k v) where+  empty = BiMap Map.empty Map.empty+  null  = null . biMapThere+ -- | Lookup. O(log n).-lookup :: Ord a => a -> BiMap a b -> Maybe b++lookup :: Ord k => k -> BiMap k v -> Maybe v lookup a = Map.lookup a . biMapThere --- | Inverse lookup.  O(log n).-invLookup :: Ord b => b -> BiMap a b -> Maybe a-invLookup b = Map.lookup b . biMapBack+-- | Inverse lookup. O(log n). --- | Empty bimap. O(1).-empty :: BiMap a b-empty = BiMap Map.empty Map.empty+invLookup :: Ord (Tag v) => Tag v -> BiMap k v -> Maybe k+invLookup k = Map.lookup k . biMapBack --- | Singleton bimap. O(1).-singleton :: a -> b -> BiMap a b-singleton a b = BiMap (Map.singleton a b) (Map.singleton b a)+-- | Singleton map. O(1). --- | Insert.  Overwrites existing value if present. O(Map.insert).-insert :: (Ord a, Ord b) => a -> b -> BiMap a b -> BiMap a b-insert a b (BiMap t u) = BiMap (Map.insert a b t) (Map.insert b a u)+singleton :: HasTag v => k -> v -> BiMap k v+singleton k v =+  BiMap+    (Map.singleton k v)+    (case tag v of+       Nothing -> Map.empty+       Just k' -> Map.singleton k' k) --- | Left-biased Union. O(Map.union).-union :: (Ord a, Ord b) => BiMap a b -> BiMap a b -> BiMap a b-union (BiMap t1 b1) (BiMap t2 b2) = BiMap (Map.union t1 t2) (Map.union b1 b2)+-- | Insertion. Overwrites existing values. O(log n).+--+-- Precondition: See 'insertPrecondition'. --- | Construct from a list of pairs.+insert ::+  (Ord k, HasTag v, Ord (Tag v)) =>+  k -> v -> BiMap k v -> BiMap k v+insert k v (BiMap t b) =+  BiMap+    (Map.insert k v t)+    (case tag v of+       Nothing -> b'+       Just k' -> Map.insert k' k b')+  where+  b' = case tag =<< Map.lookup k t of+    Nothing -> b+    Just k' -> Map.delete k' b++-- | The precondition for @'insert' k v m@: If @v@ has a 'tag' (@'tag'+-- v ≠ 'Nothing'@), then @m@ must not contain any mapping @k' ↦ v'@+-- for which @k ≠ k'@ and @'tag' v = 'tag' v'@.++insertPrecondition ::+  (Eq k, Eq v, Eq (Tag v), HasTag v) =>+  k -> v -> BiMap k v -> Bool+insertPrecondition k v m =+  case tag v of+    Nothing -> True+    Just _  ->+      not $ any (\(k', v') -> k' /= k && tag v == tag v') $ toList m++-- | Modifies the value at the given position, if any. If the function+-- returns 'Nothing', then the value is removed. O(log n). -----   Does not check for actual bijectivity of constructed finite map. O(n log n)-fromList :: (Ord a, Ord b) => [(a,b)] -> BiMap a b-fromList = List.foldl' (flip (uncurry insert)) empty+-- The precondition for @'alterM' f k m@ is that, if the value @v@ is+-- inserted into @m@, and @'tag' v@ is defined, then no key other than+-- @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@. --- | Turn into list, sorted ascendingly by first value.  O(Map.toList)-toList :: BiMap a b -> [(a,b)]+alterM ::+  forall k v m. (Ord k, Ord (Tag v), HasTag v, Monad m) =>+  (Maybe v -> m (Maybe v)) -> k -> BiMap k v -> m (BiMap k v)+alterM f k m@(BiMap t b) = do+  (t', r) <- runStateT (Map.alterF f' k t) Nothing+  return $ case r of+    Nothing -> m+    Just r  -> BiMap t' (updateBack r b)+  where+  f' ::+    Maybe v ->+    StateT (Maybe (Maybe (Tag v), Maybe (Tag v))) m (Maybe v)+  f' v = do+    r <- lift (f v)+    put $ Just (tag =<< v, tag =<< r)+    return r++  updateBack (k'1, k'2) =+    if k'1 == k'2+    then id+    else maybe id (flip Map.insert k) k'2 .+         maybe id Map.delete k'1++-- | Modifies the value at the given position, if any. If the function+-- returns 'Nothing', then the value is removed. O(log n).+--+-- Precondition: See 'alterPrecondition'.++alter ::+  forall k v. (Ord k, Ord (Tag v), HasTag v) =>+  (Maybe v -> Maybe v) -> k -> BiMap k v -> BiMap k v+alter f k m = runIdentity $ alterM (Identity . f) k m++-- | The precondition for @'alter' f k m@ is that, if the value @v@ is+-- inserted into @m@, and @'tag' v@ is defined, then no key other than+-- @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@.++alterPrecondition ::+  (Ord k, Eq v, 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+    Nothing -> True+    Just k' -> and+      [ Just k' /= tag v+      | (k'', v) <- toList m+      , k'' /= k+      ]++-- | Modifies the value at the given position, if any. If the function+-- returns 'Nothing', then the value is removed. O(log n).+--+-- Precondition: See 'updatePrecondition'.++update ::+  (Ord k, Ord (Tag v), HasTag v) =>+  (v -> Maybe v) -> k -> BiMap k v -> BiMap k v+update f = alter (f =<<)++-- | The precondition for @'update' f k m@ is that, if the value @v@+-- is inserted into @m@, and @'tag' v@ is defined, then no key other+-- than @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@.++updatePrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  (v -> Maybe v) -> k -> BiMap k v -> Bool+updatePrecondition f = alterPrecondition (f =<<)++-- | Modifies the value at the given position, if any. O(log n).+--+-- Precondition: See 'adjustPrecondition'.++adjust ::+  (Ord k, Ord (Tag v), HasTag v) =>+  (v -> v) -> k -> BiMap k v -> BiMap k v+adjust f = update (Just . f)++-- | The precondition for @'adjust' f k m@ is that, if the value @v@+-- is inserted into @m@, and @'tag' v@ is defined, then no key other+-- than @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@.++adjustPrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  (v -> v) -> k -> BiMap k v -> Bool+adjustPrecondition f = updatePrecondition (Just . f)++-- | Inserts a binding into the map. If a binding for the key already+-- exists, then the value obtained by applying the function to the+-- key, the new value and the old value is inserted, and the old value+-- is returned.+--+-- Precondition: See 'insertLookupWithKeyPrecondition'.++insertLookupWithKey ::+  forall k v. (Ord k, Ord (Tag v), HasTag v) =>+  (k -> v -> v -> v) -> k -> v -> BiMap k v -> (Maybe v, BiMap k v)+insertLookupWithKey f k v m = swap $ runState (alterM f' k m) Nothing+  where+  f' :: Maybe v -> State (Maybe v) (Maybe v)+  f' Nothing     = return $ Just v+  f' r@(Just v') = do+    put r+    return $ Just (f k v v')++-- | The precondition for @'insertLookupWithKey' f k v m@ is that, if+-- the value @v'@ is inserted into @m@, and @'tag' v'@ is defined,+-- then no key other than @k@ may map to a value @v''@ for which+-- @'tag' v'' = 'tag' v'@.++insertLookupWithKeyPrecondition ::+  (Ord k, Eq v, 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++-- | Changes all the values using the given function, which is also+-- given access to keys. O(n log n).+--+-- Precondition: See 'mapWithKeyPrecondition'.++mapWithKey ::+  (Ord k, Ord (Tag v), HasTag v) =>+  (k -> v -> v) -> BiMap k v -> BiMap k v+mapWithKey f = fromList . map (\(k, v) -> (k, f k v)) . toList++-- | The precondition for @'mapWithKey' f m@: For any two distinct+-- mappings @k₁ ↦ v₁@, @k₂ ↦ v₂@ in @m@ for which the tags of+-- @f k₁ v₁@ and @f k₂ v₂@ are defined the values of @f@ must be+-- distinct (@f k₁ v₁ ≠ f k₂ v₂@). Furthermore 'tag' must be injective+-- for @{ f k v | (k, v) ∈ m }@.++mapWithKeyPrecondition ::+  (Eq k, Eq v, Eq (Tag v), HasTag v) =>+  (k -> v -> v) -> BiMap k v -> Bool+mapWithKeyPrecondition f =+  fromListPrecondition . map (\(k, v) -> (k, f k v)) . toList++-- | Changes all the values using the given function, which is also+-- given access to keys. O(n).+--+-- Precondition: See 'mapWithKeyFixedTagsPrecondition'. Note that tags+-- must not change.++mapWithKeyFixedTags :: (k -> v -> v) -> BiMap k v -> BiMap k v+mapWithKeyFixedTags f (BiMap t b) = BiMap (Map.mapWithKey f t) b++-- | The precondition for @'mapWithKeyFixedTags' f m@ is that, if @m@+-- 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+mapWithKeyFixedTagsPrecondition f m = and+  [ tag (f k v) == tag v+  | (k, v) <- toList m+  ]++-- | Left-biased union. For the time complexity, see 'Map.union'.+--+-- Precondition: See 'unionPrecondition'.++union :: (Ord k, Ord (Tag v)) => BiMap k v -> BiMap k v -> BiMap k v+union (BiMap t1 b1) (BiMap t2 b2) =+  BiMap (Map.union t1 t2) (Map.union b1 b2)++-- The precondition for @'union' m₁ m₂@: If @k@ is mapped to @v₁@ in+-- @m₁@ and @v₂@ in @m₂@, then @'tag' v₂ = 'Nothing'@ or @'tag' v₁ =+-- 'tag' v₂@. Furthermore, if @k₁@ is mapped to @v₁@ in @m₁@ and @k₂@+-- is mapped to @v₂@ in @m₂@, where @'tag' v₁ = 'tag' v₂ = 'Just' k@,+-- then @k₁ = k₂@. Finally 'tag' must be injective for+-- @{v₁ | (k₁, v₁) ∈ m₁} ∪ {v₂ | (k₂, v₂) ∈ m₂, k₂ ∉ m₁}@.++unionPrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  BiMap k v -> BiMap k v -> Bool+unionPrecondition m1@(BiMap t1 _) m2@(BiMap t2 _) =+  and+    [ tag v2 == Nothing || tag v1 == tag v2+    | (v1, v2) <- Map.elems $ Map.intersectionWith (,) t1 t2+    ] &&+  and+    [ k1 == k2+    | (k1, v1) <- toList m1+    , (k2, v2) <- toList m2+    , tag v1 == tag v2+    , isJust (tag v1)+    ]+    &&+  tagInjectiveFor+    ([ v1+     | (_, v1) <- toList m1+     ] +++     [ v2+     | (k2, v2) <- toList m2+     , not (k2 `elem` ks1)+     ])+  where+  ks1 = map fst (toList m1)++-- | Conversion from lists of pairs. Later entries take precedence+-- over earlier ones. O(n log n).+--+-- Precondition: See 'fromListPrecondition'.++fromList ::+  (Ord k, Ord (Tag v), HasTag v) =>+  [(k, v)] -> BiMap k v+fromList = List.foldr (uncurry insert) empty++-- The precondition for @'fromList' kvs@: For all pairs @(k₁, v₁)@,+-- @(k₂, v₂)@ in @kvs@ for which the tags of @v₁@ and @v₂@ are+-- defined, if @v₁ = v₂@ then @k₁ = k₂@. Furthermore 'tag' must be+-- injective for the values in the list.++fromListPrecondition ::+  (Eq k, Eq v, Eq (Tag v), HasTag v) =>+  [(k, v)] -> Bool+fromListPrecondition kvs =+  and+    [ k1 == k2+    | (k1, v1) <- kvs+    , (k2, v2) <- kvs+    , isJust (tag v1)+    , isJust (tag v2)+    , v1 == v2+    ]+    &&+  tagInjectiveFor (map snd kvs)++-- | Conversion to lists of pairs, with the keys in ascending order.+-- O(n).++toList :: BiMap k v -> [(k, v)] toList = Map.toAscList . biMapThere +-- | The keys, in ascending order. O(n).++keys :: BiMap k v -> [k]+keys = Map.keys . biMapThere++-- | The values, ordered according to the corresponding keys. O(n).++elems :: BiMap k v -> [v]+elems = Map.elems . biMapThere++-- | Conversion from two lists that contain distinct keys/tags, with+-- the keys/tags in ascending order. O(n).+--+-- Precondition: See 'fromDistinctAscendingListsPrecondition'.++fromDistinctAscendingLists ::+  ([(k, v)], [(Tag v, k)]) -> BiMap k v+fromDistinctAscendingLists (t, b) =+  BiMap (Map.fromDistinctAscList t) (Map.fromDistinctAscList b)++-- The precondition for @'fromDistinctAscendingLists' (kvs, kks)@: The+-- lists must contain distinct keys/tags, and must be sorted according+-- to the keys/tags. Furthermore, for every pair @(k, v)@ in the first+-- list for which @'tag' v = 'Just' k'@ there must be a pair @(k', k)@+-- in the second list, and there must not be any other pairs in that+-- list. Finally 'tag' must be injective for @{v | (_, v) ∈ kvs }@.++fromDistinctAscendingListsPrecondition ::+  (Ord k, Eq v, Ord (Tag v), HasTag v) =>+  ([(k, v)], [(Tag v, k)]) -> Bool+fromDistinctAscendingListsPrecondition (kvs, kks) =+  fastDistinct (map fst kvs) && sorted (map fst kvs)+    &&+  fastDistinct (map fst kks) && sorted (map fst kks)+    &&+  kks ==+  List.sortBy (comparing fst)+    [ (k', k)+    | (k, v) <- kvs+    , Just k' <- [tag v]+    ]+    &&+  tagInjectiveFor [ v | (_, v) <- kvs ]++-- | Generates input suitable for 'fromDistinctAscendingLists'. O(n).++toDistinctAscendingLists :: BiMap k v -> ([(k, v)], [(Tag v, k)])+toDistinctAscendingLists (BiMap t b) =+  (Map.toAscList t, Map.toAscList b)+ ------------------------------------------------------------------------ -- Instances ------------------------------------------------------------------------ -instance (Ord a, Ord b) => Eq (BiMap a b) where+instance (Eq k, Eq v) => Eq (BiMap k v) where   (==) = (==) `on` biMapThere -instance (Ord a, Ord b) => Ord (BiMap a b) where+instance (Ord k, Ord v) => Ord (BiMap k v) where   compare = compare `on` biMapThere -instance (Show a, Show b) => Show (BiMap a b) where+instance (Show k, Show v) => Show (BiMap k v) where   show bimap = "Agda.Utils.BiMap.fromList " ++ show (toList bimap)

+ src/full/Agda/Utils/CallStack.hs view

@@ -0,0 +1,3 @@+module Agda.Utils.CallStack (module Exports) where+import Agda.Utils.CallStack.Base as Exports+import Agda.Utils.CallStack.Pretty as Exports ()

+ src/full/Agda/Utils/CallStack/Base.hs view

@@ -0,0 +1,140 @@++module Agda.Utils.CallStack.Base (+  -- * Simple type aliases+    SrcLocPackage+  , SrcLocModule+  , SrcFun+  , SrcLocFile+  , SrcLocLine+  , SrcLocCol+  , CallSite+  , CallSiteFilter++  -- * String-based "pretty" representations+  , prettySrcLoc+  , prettyCallSite+  , prettyCallStack++  -- * Generic utilities over CallStack and CallSite+  , filterCallStack+  , headCallSite+  , overCallSites+  , popnCallStack+  , truncatedCallStack+  , withCallerCallStack+  , withCurrentCallStack+  , withNBackCallStack++  -- * Re-exported stuff+  , CallStack+  , callStack+  , fromCallSiteList+  , getCallStack+  , HasCallStack+  , SrcLoc(..)+  )+  where++import Data.List ( intercalate )+import Data.Maybe ( listToMaybe )+import GHC.Stack+  ( callStack+  , CallStack+  , emptyCallStack+  , fromCallSiteList+  , getCallStack+  , HasCallStack+  , popCallStack+  , prettySrcLoc+  , SrcLoc(..)+  )++-- * Type aliases++-- | Type of the package name of a @SrcLoc@+-- | e.g. `Agda-2.…`+type SrcLocPackage = String++-- | Type of the module name of a @SrcLoc@+-- | e.g. `Agda.Utils.Foo`+type SrcLocModule = String++-- | Type of the name of a function in a @CallSite@+-- | e.g. `proveEverything`+type SrcFun = String++-- | Type of a filename of a @SrcLoc@+-- | e.g. `src/full/Agda/Utils/Foo.hs`+type SrcLocFile = String++-- | Type of a line number of a @SrcLoc@+type SrcLocLine = Int++-- | Type of a column of a @SrcLoc@+type SrcLocCol = Int++-- | Type of an entry in  a @CallStack@+type CallSite = (SrcFun, SrcLoc)++-- | Type of a filter for @CallSite@+type CallSiteFilter = CallSite -> Bool++-- * Simple String representations+-- Note that there are @Agda.Utils.Pretty@ instances defined in @Agda.Utils.CallStack.Pretty@++-- | The same as the un-exported internal function in @GHC.Exceptions (prettyCallStackLines)@+--  Prints like: @doFoo, called at foo.hs:190:24 in main:Main@+prettyCallSite :: CallSite -> String+prettyCallSite (fun, loc) = fun ++ ", called at " ++ prettySrcLoc loc++-- | Pretty-print a @CallStack@. This has a few differences from @GHC.Stack.prettyCallStackLines@.+-- We omit the "CallStack (from GetCallStack)" header line for brevity.+-- If there is only one entry (which is common, due to the manual nature of the @HasCallStack@ constraint),+-- shows the entry on one line. If there are multiple, then the following lines are indented.+prettyCallStack :: CallStack -> String+prettyCallStack cs = case map prettyCallSite (getCallStack cs) of+  []                  -> "(empty CallStack)"+  firstLoc : restLocs -> intercalate "\n" (firstLoc : (map ("  " ++) restLocs))++-- * Generic utilities over CallStack and CallSite++-- | Get the most recent @CallSite@ in a @CallStack@, if there is one.+headCallSite :: CallStack -> Maybe CallSite+headCallSite = listToMaybe . getCallStack++-- | @CallStack@ comprising only the most recent @CallSite@+truncatedCallStack :: CallStack -> CallStack+truncatedCallStack cs = maybe emptyCallStack (fromCallSiteList . pure) (headCallSite cs)++-- | Transform a @CallStack@ by transforming its list of @CallSite@+overCallSites :: ([CallSite] -> [CallSite]) -> CallStack -> CallStack+overCallSites f = fromCallSiteList . f . getCallStack++-- | Transform a @CallStack@ by filtering each @CallSite@+filterCallStack :: CallSiteFilter -> CallStack -> CallStack+filterCallStack = overCallSites . filter++-- | Pops n entries off a @CallStack@ using @popCallStack@.+-- Note that frozen callstacks are unaffected.+popnCallStack :: Word -> CallStack -> CallStack+popnCallStack 0 = id+popnCallStack n = (popnCallStack (n - 1)) . popCallStack++withNBackCallStack :: HasCallStack => Word -> (CallStack -> b) -> b+withNBackCallStack n f = f (popnCallStack n from)+  where+    -- This very line (always dropped):+    here = callStack+    -- The invoker (n = 0):+    from = popCallStack here++withCurrentCallStack :: HasCallStack => (CallStack -> b) -> b+withCurrentCallStack = withNBackCallStack 0+  -- 0 => this line in this utility function.+  -- 1 => the invocation of this utility function.++withCallerCallStack :: HasCallStack => (CallStack -> b) -> b+withCallerCallStack = withNBackCallStack 1+  -- 0 => this line in this utility function.+  -- 1 => our caller.+  -- 2 => their caller.

+ src/full/Agda/Utils/CallStack/Pretty.hs view

@@ -0,0 +1,32 @@+module Agda.Utils.CallStack.Pretty+  ( -- This module only exports instances.+  ) where++import Agda.Utils.CallStack.Base+  ( CallSite+  , CallStack+  , SrcLoc(..)+  , getCallStack+  )+import Agda.Utils.Pretty+  ( (<+>), ($+$), (<>)+  , pshow, text+  , colon, comma+  , nest, parens+  , hcat, hsep, vcat+  , Pretty(pretty)+  )++instance Pretty SrcLoc where+  pretty SrcLoc {..} = hsep [physicalLoc, "in", logicalLoc]+      where+        physicalLoc = hcat [text srcLocFile, colon, pshow srcLocStartLine, colon, pshow srcLocStartCol]+        logicalLoc = hcat [text srcLocPackage, colon, text srcLocModule]++instance Pretty CallSite where+  pretty (fun, loc) = hsep [text fun <> comma, "called at", pretty loc]++instance Pretty CallStack where+  pretty cs = case fmap pretty (getCallStack cs) of+    []                  -> parens "empty CallStack"+    firstLoc : restLocs -> firstLoc $+$ nest 2 (vcat restLocs)

+ src/full/Agda/Utils/Char.hs view

@@ -0,0 +1,36 @@++-- |+-- Agda strings uses Data.Text [1], which can only represent unicode scalar values [2], excluding+-- the surrogate code points [3] (@U+D800..U+DFFF@). To allow @primStringFromList@ to be injective+-- we make sure character values also exclude surrogate code points, mapping them to the replacement+-- character @U+FFFD@.+--+-- See #4999 for more information.+--+-- [1] https://hackage.haskell.org/package/text-1.2.4.0/docs/Data-Text.html#g:2+-- [2] https://www.unicode.org/glossary/#unicode_scalar_value+-- [3] https://www.unicode.org/glossary/#surrogate_code_point++module Agda.Utils.Char where++import Data.Char++-- | The unicode replacement character � .+replacementChar :: Char+replacementChar = '\xFFFD'++-- | Is a character a surrogate code point.+isSurrogateCodePoint :: Char -> Bool+isSurrogateCodePoint c = generalCategory c == Surrogate++-- | Map surrogate code points to the unicode replacement character.+replaceSurrogateCodePoint :: Char -> Char+replaceSurrogateCodePoint c+  | isSurrogateCodePoint c = replacementChar+  | otherwise              = c++-- | Total function to convert an integer to a character. Maps surrogate code points+--   to the replacement character @U+FFFD@.+integerToChar :: Integer -> Char+integerToChar = replaceSurrogateCodePoint . toEnum . fromIntegral . (`mod` 0x110000)+

src/full/Agda/Utils/Cluster.hs view

@@ -13,7 +13,6 @@ -- An imperative union-find library: import Data.Equivalence.Monad (runEquivT, equateAll, classDesc) import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty  import qualified Data.IntMap as IntMap #if __GLASGOW_HASKELL__ < 804

src/full/Agda/Utils/Either.hs view

@@ -20,12 +20,17 @@   , allRight   , groupByEither   , maybeToEither+  , swapEither   ) where  import Data.Bifunctor import Data.Either (isLeft, isRight)+import Data.List   (unfoldr) -import Agda.Utils.List ( listCase )+import Agda.Utils.List ( spanJust )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Singleton  -- | Loop while we have an exception. @@ -58,11 +63,11 @@  -- | Analogue of 'Data.Maybe.fromMaybe'. fromLeft :: (b -> a) -> Either a b -> a-fromLeft = either id+fromLeft = (id `either`)  -- | Analogue of 'Data.Maybe.fromMaybe'. fromRight :: (a -> b) -> Either a b -> b-fromRight f = either f id+fromRight = (`either` id)  -- | Analogue of 'Agda.Utils.Maybe.fromMaybeM'. fromLeftM :: Monad m => (b -> m a) -> m (Either a b) -> m a@@ -108,20 +113,18 @@ allRight = mapM maybeRight  -- | Groups a list into alternating chunks of 'Left' and 'Right' values-groupByEither :: forall a b. [Either a b] -> [Either [a] [b]]-groupByEither = listCase [] (go . init) where--  go :: Either [a] [b] -> [Either a b] -> [Either [a] [b]]-  go acc         []              = adjust acc : []-  -- match: next value can be tacked onto the accumulator-  go (Left  acc) (Left  a : abs) = go (Left  $ a : acc) abs-  go (Right acc) (Right b : abs) = go (Right $ b : acc) abs-  -- mismatch: switch the accumulator to the other mode-  go acc         (ab      : abs) = adjust acc : go (init ab) abs+groupByEither :: forall a b. [Either a b] -> [Either (List1 a) (List1 b)]+groupByEither = unfoldr c+  where+  c :: [Either a b] -> Maybe (Either (List1 a) (List1 b), [Either a b])+  c []             = Nothing+  c (Left  a : xs) = Just $ first (Left  . (a :|)) $ spanJust maybeLeft  xs+  c (Right b : xs) = Just $ first (Right . (b :|)) $ spanJust maybeRight xs -  adjust = bimap reverse reverse-  init   = bimap pure pure+-- | Convert 'Maybe' to @'Either' e@, given an error @e@ for the 'Nothing' case.+maybeToEither :: e -> Maybe a -> Either e a+maybeToEither e = maybe (Left e) Right --- | Convert 'Maybe' to @'Either' ()@.-maybeToEither :: Maybe a -> Either () a-maybeToEither = maybe (Left ()) Right+-- | Swap tags 'Left' and 'Right'.+swapEither :: Either a b -> Either b a+swapEither = either Right Left

src/full/Agda/Utils/Empty.hs view

@@ -1,18 +1,23 @@-{-# LANGUAGE DeriveDataTypeable #-}- -- | An empty type with some useful instances. module Agda.Utils.Empty where +import Control.DeepSeq import Control.Exception (evaluate) -import Data.Functor ((<$)) import Data.Data (Data)  import Agda.Utils.Impossible   data Empty+ deriving instance Data Empty++-- | Values of type 'Empty' are not forced, because 'Empty' is used as+-- a constructor argument in 'Agda.Syntax.Internal.Substitution''.++instance NFData Empty where+  rnf _ = ()  instance Eq Empty where   _ == _ = True

src/full/Agda/Utils/Environment.hs view

@@ -9,38 +9,48 @@  expandEnvironmentVariables :: String -> IO String expandEnvironmentVariables s = do-  env <- getEnvironment+  env  <- getEnvironment   home <- getHomeDirectory   return $ expandVars home env s -expandVars :: String -> [(String, String)] -> String -> String+expandVars+  :: String              -- ^ Home directory.+  -> [(String, String)]  -- ^ Environment variable substitution map.+  -> String              -- ^ Input.+  -> String              -- ^ Output with variables and @~@ (home) substituted. expandVars home env s = concatMap repl $ tokens s   where-    repl Home = home ++ "/"+    repl Home    = home ++ "/"     repl (Var x) = fromMaybe "" $ lookup x env     repl (Str s) = s -data Token = Home | Var String | Str String+-- | Tokenization for environment variable substitution.+data Token+  = Home        -- ^ @~@.+  | Var String  -- ^ @$VARIABLE@ or @${VARIABLE}$.+  | Str String  -- ^ Ordinary characters.   deriving (Eq, Show) +-- | Tokenize a string.+--   The @~@ is recognized as @$HOME@ only at the beginning of the string. tokens :: String -> [Token]-tokens s = case s of-  '~' : '/' : s -> Home : tokens' s+tokens = \case+  '~'  : '/' : s -> Home : tokens' s   '\\' : '~' : s -> cons '~' $ tokens' s-  _ -> tokens' s+  s -> tokens' s   where     tokens' :: String -> [Token]-    tokens' s =-      case s of+    tokens' = \case         '$' : '$' : s -> cons '$' $ tokens' s         '$' : s@(c : _) | c == '_' || isAlpha c -> Var x : tokens' s'-          where (x, s') = span (\ c -> c == '_' || isAlphaNum c) s+          where+          (x, s') = span (\ c -> c == '_' || isAlphaNum c) s         '$' : '{' : s ->           case break (== '}') s of             (x, '}' : s) -> Var x : tokens' s             _            -> [Str $ "${" ++ s] -- abort on unterminated '{'         c : s -> cons c $ tokens' s         ""    -> []+    cons :: Char -> [Token] -> [Token]     cons c (Str s : ts) = Str (c : s) : ts     cons c ts           = Str [c] : ts-

− src/full/Agda/Utils/Except.hs

@@ -1,37 +0,0 @@----------------------------------------------------------------------------------- | Wrapper for Control.Monad.Except from the mtl library (>= 2.2.1)---------------------------------------------------------------------------------module Agda.Utils.Except-  ( Error(noMsg, strMsg)-  , ExceptT-  , mapExceptT-  , mkExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  ) where--import Control.Monad.Except------------------------------------------------------------------------------ | We cannot define data constructors synonymous, so we define the--- @mkExceptT@ function to be used instead of the data constructor--- @ExceptT@.-mkExceptT :: m (Either e a) -> ExceptT e m a-mkExceptT = ExceptT---- | Error class for backward compatibility (from--- Control.Monad.Trans.Error in transformers 0.3.0.0).--class Error a where-  noMsg  :: a-  strMsg :: String -> a--  noMsg    = strMsg ""-  strMsg _ = noMsg---- | A string can be thrown as an error.-instance Error String where-  strMsg = id

src/full/Agda/Utils/Fail.hs view

@@ -1,7 +1,7 @@ -- | A pure MonadFail.-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Agda.Utils.Fail where +-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail  newtype Fail a = Fail { runFail :: Either String a }@@ -12,4 +12,3 @@  runFail_ :: Fail a -> a runFail_ = either error id . runFail-

src/full/Agda/Utils/Favorites.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Maintaining a list of favorites of some partially ordered type. --   Only the best elements are kept.@@ -14,7 +13,6 @@  import Prelude hiding ( null ) -import Data.Foldable (Foldable) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif

src/full/Agda/Utils/FileName.hs view

@@ -1,6 +1,4 @@ {-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-| Operations on file names. -} module Agda.Utils.FileName@@ -8,26 +6,29 @@   , filePath   , mkAbsolute   , absolute-  , (===)+  , canonicalizeAbsolutePath+  , sameFile   , doesFileExistCaseSensitive-  , rootPath+  , isNewerThan   ) where  import System.Directory import System.FilePath +import Control.Applicative ( liftA2 )+import Control.DeepSeq #ifdef mingw32_HOST_OS-import Control.Exception (bracket)-import System.Win32 (findFirstFile, findClose, getFindDataFileName)-import Agda.Utils.Monad+import Control.Exception   ( bracket )+import System.Win32        ( findFirstFile, findClose, getFindDataFileName ) #endif -import Data.Text (Text)-import qualified Data.Text as Text+import Data.Data           ( Data ) import Data.Function-import Data.Hashable (Hashable)-import Data.Data (Data)+import Data.Hashable       ( Hashable )+import Data.Text           ( Text )+import qualified Data.Text as Text +import Agda.Utils.Monad import Agda.Utils.Pretty  import Agda.Utils.Impossible@@ -37,19 +38,12 @@ -- Note that the 'Eq' and 'Ord' instances do not check if different -- paths point to the same files or directories. -newtype AbsolutePath = AbsolutePath { byteStringPath :: Text }-  deriving (Eq, Ord, Data, Hashable)+newtype AbsolutePath = AbsolutePath { textPath :: Text }+  deriving (Show, Eq, Ord, Data, Hashable, NFData)  -- | Extract the 'AbsolutePath' to be used as 'FilePath'. filePath :: AbsolutePath -> FilePath-filePath = Text.unpack . byteStringPath---- TODO: 'Show' should output Haskell-parseable representations.--- The following instance is deprecated, and Pretty should be used--- instead.  Later, simply derive Show for this type.--instance Show AbsolutePath where-  show = filePath+filePath = Text.unpack . textPath  instance Pretty AbsolutePath where   pretty = text . filePath@@ -62,16 +56,10 @@ mkAbsolute f   | isAbsolute f =       AbsolutePath $ Text.pack $ dropTrailingPathSeparator $ normalise f+        -- normalize does not resolve symlinks   | otherwise    = __IMPOSSIBLE__ -rootPath :: FilePath-#ifdef mingw32_HOST_OS-rootPath = joinDrive "C:" [pathSeparator]-#else-rootPath = [pathSeparator]-#endif---- UNUSED Linag-Ting Chen 2019-07-16+-- UNUSED Liang-Ting Chen 2019-07-16 ---- | maps @/bla/bla/bla/foo.bar.xxx@ to @foo.bar@. --rootName :: AbsolutePath -> String --rootName = dropExtension . snd . splitFileName . filePath@@ -85,24 +73,28 @@ absolute f = mkAbsolute <$> do   -- canonicalizePath sometimes truncates paths pointing to   -- non-existing files/directories.-  ex <- doesFileExist f .||. doesDirectoryExist f-  if ex then-    canonicalizePath f+  ex <- doesFileExist f `or2M` doesDirectoryExist f+  if ex then do+    -- Andreas, 2020-08-11, issue #4828+    -- Do not use @canonicalizePath@ on the full path as it resolves symlinks,+    -- which leads to wrong placement of the .agdai file.+    dir <- canonicalizePath (takeDirectory f)+    return (dir </> takeFileName f)    else do     cwd <- getCurrentDirectory     return (cwd </> f)-  where-  m1 .||. m2 = do-    b1 <- m1-    if b1 then return True else m2 +-- | Resolve symlinks etc.  Preserves 'sameFile'.++canonicalizeAbsolutePath :: AbsolutePath -> IO AbsolutePath+canonicalizeAbsolutePath (AbsolutePath f) =+  AbsolutePath . Text.pack <$> canonicalizePath (Text.unpack f)+ -- | Tries to establish if the two file paths point to the same file -- (or directory). -infix 4 ===--(===) :: AbsolutePath -> AbsolutePath -> Bool-(===) = equalFilePath `on` filePath+sameFile :: AbsolutePath -> AbsolutePath -> IO Bool+sameFile = liftA2 equalFilePath `on` (canonicalizePath . filePath)  -- | Case-sensitive 'doesFileExist' for Windows. --@@ -120,3 +112,16 @@ #else doesFileExistCaseSensitive = doesFileExist #endif++-- | True if the first file is newer than the second file. If a file doesn't+-- exist it is considered to be infinitely old.+isNewerThan :: FilePath -> FilePath -> IO Bool+isNewerThan new old = do+    newExist <- doesFileExist new+    oldExist <- doesFileExist old+    if not (newExist && oldExist)+        then return newExist+        else do+            newT <- getModificationTime new+            oldT <- getModificationTime old+            return $ newT >= oldT

src/full/Agda/Utils/Float.hs view

@@ -2,32 +2,220 @@  -- | Logically consistent comparison of floating point numbers. module Agda.Utils.Float-  ( normaliseNaN+  ( asFinite+  , isPosInf+  , isNegInf+  , isPosZero+  , isNegZero+  , isSafeInteger+  , doubleEq+  , doubleLe+  , doubleLt+  , intToDouble+  , doublePlus+  , doubleMinus+  , doubleTimes+  , doubleNegate+  , doubleDiv+  , doublePow+  , doubleSqrt+  , doubleExp+  , doubleLog+  , doubleSin+  , doubleCos+  , doubleTan+  , doubleASin+  , doubleACos+  , doubleATan+  , doubleATan2+  , doubleSinh+  , doubleCosh+  , doubleTanh+  , doubleASinh+  , doubleACosh+  , doubleATanh+  , doubleRound+  , doubleFloor+  , doubleCeiling+  , doubleDenotEq+  , doubleDenotOrd   , doubleToWord64-  , floatEq-  , floatLt+  , doubleToRatio+  , ratioToDouble+  , doubleDecode+  , doubleEncode   , toStringWithoutDotZero   ) where +import Data.Bifunctor   ( bimap, second )+import Data.Function    ( on ) import Data.Maybe       ( fromMaybe )-import Data.Word-import Numeric.IEEE     ( IEEE(identicalIEEE, nan) )+import Data.Ratio       ( (%), numerator, denominator )+import Data.Word        ( Word64 )++import Agda.Utils.List  ( stripSuffix )+ #if __GLASGOW_HASKELL__ >= 804-import GHC.Float        ( castDoubleToWord64 )+import GHC.Float (castDoubleToWord64, castWord64ToDouble) #else-import System.IO.Unsafe ( unsafePerformIO )-import qualified Foreign as F+import System.IO.Unsafe (unsafePerformIO)+import qualified Foreign          as F+import qualified Foreign.Storable as F #endif -import Agda.Utils.List  ( stripSuffix )- #if __GLASGOW_HASKELL__ < 804 castDoubleToWord64 :: Double -> Word64 castDoubleToWord64 float = unsafePerformIO $ F.alloca $ \buf -> do   F.poke (F.castPtr buf) float   F.peek buf++castWord64ToDouble :: Word64 -> Double+castWord64ToDouble word = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) word+  F.peek buf #endif +{-# INLINE doubleEq #-}+doubleEq :: Double -> Double -> Bool+doubleEq = (==)++{-# INLINE doubleLe #-}+doubleLe :: Double -> Double -> Bool+doubleLe = (<=)++{-# INLINE doubleLt #-}+doubleLt :: Double -> Double -> Bool+doubleLt = (<)++truncateDouble :: Double -> Double+truncateDouble = castWord64ToDouble . castDoubleToWord64++{-# INLINE intToDouble #-}+intToDouble :: Integral a => a -> Double+intToDouble = truncateDouble . fromIntegral++{-# INLINE doublePlus #-}+doublePlus :: Double -> Double -> Double+doublePlus x y = truncateDouble (x + y)++{-# INLINE doubleMinus #-}+doubleMinus :: Double -> Double -> Double+doubleMinus x y = truncateDouble (x - y)++{-# INLINE doubleTimes #-}+doubleTimes :: Double -> Double -> Double+doubleTimes x y = truncateDouble (x * y)++{-# INLINE doubleNegate #-}+doubleNegate :: Double -> Double+doubleNegate = negate -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleDiv #-}+doubleDiv :: Double -> Double -> Double+doubleDiv = (/) -- NOTE: doesn't cause underflow/overflow++{-# INLINE doublePow #-}+doublePow :: Double -> Double -> Double+doublePow x y = truncateDouble (x ** y)++{-# INLINE doubleSqrt #-}+doubleSqrt :: Double -> Double+doubleSqrt = sqrt -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleExp #-}+doubleExp :: Double -> Double+doubleExp x = truncateDouble (exp x)++{-# INLINE doubleLog #-}+doubleLog :: Double -> Double+doubleLog = log -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSin #-}+doubleSin :: Double -> Double+doubleSin = sin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCos #-}+doubleCos :: Double -> Double+doubleCos = cos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTan #-}+doubleTan :: Double -> Double+doubleTan = tan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASin #-}+doubleASin :: Double -> Double+doubleASin = asin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACos #-}+doubleACos :: Double -> Double+doubleACos = acos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan #-}+doubleATan :: Double -> Double+doubleATan = atan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan2 #-}+doubleATan2 :: Double -> Double -> Double+doubleATan2 = atan2 -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSinh #-}+doubleSinh :: Double -> Double+doubleSinh = sinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCosh #-}+doubleCosh :: Double -> Double+doubleCosh = cosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTanh #-}+doubleTanh :: Double -> Double+doubleTanh = tanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASinh #-}+doubleASinh :: Double -> Double+doubleASinh = asinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACosh #-}+doubleACosh :: Double -> Double+doubleACosh = acosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATanh #-}+doubleATanh :: Double -> Double+doubleATanh = atanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE negativeZero #-}+negativeZero :: Double+negativeZero = -0.0++positiveInfinity :: Double+positiveInfinity = 1.0 / 0.0++negativeInfinity :: Double+negativeInfinity = -positiveInfinity++nan :: Double+nan = 0.0 / 0.0++isPosInf :: Double -> Bool+isPosInf x = x > 0.0 && isInfinite x++isNegInf :: Double -> Bool+isNegInf x = x < 0.0 && isInfinite x++isPosZero :: Double -> Bool+isPosZero x = doubleDenotEq x 0.0++isNegZero :: Double -> Bool+isNegZero x = doubleDenotEq x (-0.0)++doubleRound :: Double -> Maybe Integer+doubleRound = fmap round . asFinite++doubleFloor :: Double -> Maybe Integer+doubleFloor = fmap floor . asFinite++doubleCeiling :: Double -> Maybe Integer+doubleCeiling = fmap ceiling . asFinite+ normaliseNaN :: Double -> Double normaliseNaN x   | isNaN x   = nan@@ -36,29 +224,103 @@ doubleToWord64 :: Double -> Word64 doubleToWord64 = castDoubleToWord64 . normaliseNaN -floatEq :: Double -> Double -> Bool-floatEq x y = identicalIEEE x y  || (isNaN x && isNaN y)+-- |Denotational equality for floating point numbers, checks bitwise equality.+--+--  NOTE: Denotational equality distinguishes NaNs, so its results may vary+--        depending on the architecture and compilation flags. Unfortunately,+--        this is a problem with floating-point numbers in general.+--+doubleDenotEq :: Double -> Double -> Bool+doubleDenotEq = (==) `on` doubleToWord64 -floatLt :: Double -> Double -> Bool-floatLt x y =-  case compareFloat x y of-    LT -> True-    _  -> False-  where-    -- Also implemented in the GHC backend-    compareFloat :: Double -> Double -> Ordering-    compareFloat x y-      | identicalIEEE x y          = EQ-      | isNegInf x                 = LT-      | isNegInf y                 = GT-      | isNaN x && isNaN y         = EQ-      | isNaN x                    = LT-      | isNaN y                    = GT-      | otherwise                  = compare (x, isNegZero y) (y, isNegZero x)-    isNegInf  z = z < 0 && isInfinite z-    isNegZero z = identicalIEEE z (-0.0)+-- |I guess "denotational orderings" are now a thing? The point is that we need+--  an Ord instance which provides a total ordering, and is consistent with the+--  denotational equality.+--+--  NOTE: The ordering induced via `doubleToWord64` is total, and is consistent+--        with `doubleDenotEq`. However, it is *deeply* unintuitive. For one, it+--        considers all negative numbers to be larger than positive numbers.+--+doubleDenotOrd :: Double -> Double -> Ordering+doubleDenotOrd = compare `on` doubleToWord64 --- | Remove suffix @.0@ from printed floating point number.+-- |Return Just x if it's a finite number, otherwise return Nothing.+asFinite :: Double -> Maybe Double+asFinite x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just x++-- |Remove suffix @.0@ from printed floating point number. toStringWithoutDotZero :: Double -> String toStringWithoutDotZero d = fromMaybe s $ stripSuffix ".0" s   where s = show d++-- |Decode a Double to an integer ratio.+doubleToRatio :: Double -> (Integer, Integer)+doubleToRatio x+  | isNaN      x = (0, 0)+  | isInfinite x = (signum (floor x), 0)+  | otherwise    = let r = toRational x in (numerator r, denominator r)++-- |Encode an integer ratio as a double.+ratioToDouble :: Integer -> Integer -> Double+ratioToDouble n d+  | d == 0 = case compare n 0 of+      LT -> negativeInfinity+      EQ -> nan+      GT -> positiveInfinity+  | otherwise = fromRational (n % d)++-- |Decode a Double to its mantissa and its exponent, normalised such that the+--  mantissa is the smallest possible number without loss of accuracy.+doubleDecode :: Double -> Maybe (Integer, Integer)+doubleDecode x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just (uncurry normalise (second toInteger (decodeFloat x)))+  where+    normalise :: Integer -> Integer -> (Integer, Integer)+    normalise mantissa exponent+      | even mantissa = normalise (mantissa `div` 2) (exponent + 1)+      | otherwise = (mantissa, exponent)++-- |Checks whether or not the Double is within a safe range of operation.+isSafeInteger :: Double -> Bool+isSafeInteger x = case properFraction x of+  (n, f) -> f == 0.0 && minMantissa <= n && n <= maxMantissa++doubleRadix :: Integer+doubleRadix = floatRadix (undefined :: Double)++doubleDigits :: Int+doubleDigits = floatDigits (undefined :: Double)++doubleRange :: (Int, Int)+doubleRange = floatRange (undefined :: Double)++-- |The smallest representable mantissa. Simultaneously, the smallest integer which can be+--  represented as a Double without loss of precision.+minMantissa :: Integer+minMantissa = - maxMantissa++-- |The largest representable mantissa. Simultaneously, the largest integer which can be+--  represented as a Double without loss of precision.+maxMantissa :: Integer+maxMantissa = (doubleRadix ^ toInteger doubleDigits) - 1++-- |The largest representable exponent.+minExponent :: Integer+minExponent = toInteger $ (fst doubleRange - doubleDigits) - 1++-- |The smallest representable exponent.+maxExponent :: Integer+maxExponent = toInteger $ snd doubleRange - doubleDigits++-- |Encode a mantissa and an exponent as a Double.+doubleEncode :: Integer -> Integer -> Maybe Double+doubleEncode mantissa exponent+  = if minMantissa <= mantissa && mantissa <= maxMantissa &&+       minExponent <= exponent && exponent <= maxExponent+    then Just (encodeFloat mantissa (fromInteger exponent))+    else Nothing

src/full/Agda/Utils/Functor.hs view

@@ -19,7 +19,7 @@  import Control.Applicative ( Const(Const), getConst ) -import Data.Functor ((<$>), ($>))+import Data.Functor (($>)) import Data.Functor.Identity import Data.Functor.Compose

− src/full/Agda/Utils/Geniplate.hs

@@ -1,54 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Utilities related to Geniplate.--module Agda.Utils.Geniplate-  ( instanceUniverseBiT'-  , instanceTransformBiMT'-  , dontDescendInto-  ) where--import Data.Generics.Geniplate-import Data.Map (Map)--import qualified Language.Haskell.TH as TH--import qualified Agda.Syntax.Abstract.Name as A-import qualified Agda.Syntax.Concrete.Name as C-import qualified Agda.Syntax.Position as P-import qualified Agda.Syntax.Scope.Base as S-import qualified Agda.Utils.FileName as F-import qualified Agda.Utils.Maybe.Strict as MS---- | Types which Geniplate should not descend into.--dontDescendInto :: [TH.TypeQ]-dontDescendInto =-  [ [t| String |]-  , [t| A.QName |]-  , [t| A.Name |]-  , [t| C.Name |]-  , [t| S.ScopeInfo |]-  , [t| Map A.QName A.QName |]-  , [t| Map A.ModuleName A.ModuleName |]-  , [t| [(A.QName, A.QName)] |]-  , [t| [(A.ModuleName, A.ModuleName)] |]-  , [t| A.AmbiguousQName |]-  , [t| P.Range' (MS.Maybe F.AbsolutePath) |]-  ]---- | A localised instance of 'instanceUniverseBiT'. The generated--- 'universeBi' functions neither descend into the types in--- 'dontDescendInto', nor into the types in the list argument.--instanceUniverseBiT' :: [TH.TypeQ] -> TH.TypeQ -> TH.Q [TH.Dec]-instanceUniverseBiT' ts p =-  instanceUniverseBiT (ts ++ dontDescendInto) p---- | A localised instance of 'instanceTransformBiMT'. The generated--- 'transformBiM' functions neither descend into the types in--- 'dontDescendInto', nor into the types in the list argument.--instanceTransformBiMT' :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ -> TH.Q [TH.Dec]-instanceTransformBiMT' ts p =-  instanceTransformBiMT (ts ++ dontDescendInto) p

src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns               #-}- -- | Directed graphs (can of course simulate undirected graphs). -- --   Represented as adjacency maps in direction from source to target.@@ -869,4 +867,3 @@ --         NEW EDGES WILL BE ADDED! Use 'Maybe ()' instead. transitiveClosure :: (Ord n, Eq e, StarSemiRing e) => Graph n e -> Graph n e transitiveClosure = fst . gaussJordanFloydWarshallMcNaughtonYamada-

src/full/Agda/Utils/Graph/TopSort.hs view

@@ -1,19 +1,13 @@-{-# language ViewPatterns #-}+ module Agda.Utils.Graph.TopSort     ( topSort     ) where -import Data.List-import Data.Maybe-import Data.Function import qualified Data.Set as Set import qualified Data.Map as Map-import qualified Data.Graph as Graph-import Control.Arrow-import Agda.Utils.List (nubOn)-import Agda.Utils.SemiRing import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G +-- NB:: Defined but not used mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] mergeBy _ [] xs = xs mergeBy _ xs [] = xs

src/full/Agda/Utils/Haskell/Syntax.hs view

@@ -2,6 +2,8 @@  module Agda.Utils.Haskell.Syntax where +import Data.Text (Text)+ -- * Modules  data Module = Module ModuleName [ModulePragma] [ImportDecl] [Decl]@@ -81,6 +83,7 @@          | Con QName          | Lit Literal          | InfixApp Exp QOp Exp+         | Ann Exp Type          | App Exp Exp          | Lambda [Pat] Exp          | Let Binds Exp@@ -94,7 +97,7 @@ data Alt = Alt Pat Rhs (Maybe Binds)   deriving (Eq) -data Literal = Int Integer | Frac Rational | Char Char | String String+data Literal = Int Integer | Frac Rational | Char Char | String Text   deriving (Eq)  -- * Names

src/full/Agda/Utils/IO.hs view

@@ -3,6 +3,7 @@ module Agda.Utils.IO where  import Control.Exception+import Control.Monad.State import Control.Monad.Writer  -- | Catch 'IOException's.@@ -19,3 +20,8 @@ -- instance CatchIO m => CatchIO (WriterT w m) where   catchIO m h = WriterT $ runWriterT m `catchIO` \ e -> runWriterT (h e)++-- | Upon exception, the state is reset.+--+instance CatchIO m => CatchIO (StateT s m) where+  catchIO m h = StateT $ \s -> runStateT m s `catchIO` \ e -> runStateT (h e) s

src/full/Agda/Utils/IO/TempFile.hs view

@@ -4,8 +4,6 @@   ( writeToTempFile   ) where -import qualified Agda.Utils.IO.UTF8 as UTF8- import qualified Control.Exception as E import qualified System.Directory as D import qualified System.IO as IO

src/full/Agda/Utils/Impossible.hs view

@@ -6,19 +6,23 @@ module Agda.Utils.Impossible where  import Control.Exception (Exception(..), throw, catchJust)-import GHC.Stack-  (CallStack, HasCallStack, callStack, getCallStack, freezeCallStack-  , srcLocModule, srcLocFile, srcLocStartLine)+import Control.DeepSeq+import Agda.Utils.CallStack.Base+    ( CallStack+    , HasCallStack+    , prettyCallStack+    , withCallerCallStack+    )  -- | \"Impossible\" errors, annotated with a file name and a line -- number corresponding to the source code location of the error.  data Impossible -  = Impossible  String Integer+  = Impossible CallStack     -- ^ We reached a program point which should be unreachable. -  | Unreachable String Integer+  | Unreachable CallStack     -- ^ @Impossible@ with a different error message.     --   Used when we reach a program point which can in principle     --   be reached, but not for a certain run.@@ -28,18 +32,30 @@     -- primitives or BUILTIN to proceed forward.     -- @ImpMissingDefinitions neededDefs forThis@ +-- Identify all values of Impossible. We use Impossible as a stand-in for the empty type, so all+-- values are morally equal.+instance Eq Impossible where+  _ == _ = True++instance Ord Impossible where+  compare _ _ = EQ++instance NFData Impossible where+  rnf _ = ()+ instance Show Impossible where-  show (Impossible file line) = unlines+  show (Impossible loc) = unlines     [ "An internal error has occurred. Please report this as a bug."-    , "Location of the error: " ++ file ++ ":" ++ show line+    , "Location of the error: " ++ prettyCallStack loc     ]-  show (Unreachable file line) = unlines+  show (Unreachable loc) = unlines     [ "We reached a program point we did not want to reach."-    , "Location of the error: " ++ file ++ ":" ++ show line+    , "Location of the error: " ++ prettyCallStack loc     ]   show (ImpMissingDefinitions needed forthis) = unlines-    [ "The following builtins or primitives need to be bound to use " ++ forthis ++ ":"]-    ++ unwords needed+    [ "The following builtins or primitives need to be bound to use " ++ forthis ++ ":"+    , unwords needed+    ]  instance Exception Impossible @@ -74,31 +90,17 @@ instance CatchImpossible IO where   catchImpossibleJust = catchJust --- | Create something with a callstack's file and line number--withFileAndLine' :: Integral a => CallStack -> (String -> a -> b) -> b-withFileAndLine' cs ctor = ctor file line-  where-    callSiteList = getCallStack cs-    notHere (_, loc) = srcLocModule loc /= "Agda.Utils.Impossible"-    stackLocations = filter notHere callSiteList-    (file, line) = case stackLocations of-      (_, loc) : _ -> (srcLocFile loc, fromIntegral (srcLocStartLine loc))-      [] -> ("?", -1)---- | Create something with the call site's file and line number--withFileAndLine :: (HasCallStack, Integral a) => (String -> a -> b) -> b-withFileAndLine = withFileAndLine' (freezeCallStack callStack)- -- | Throw an "Impossible" error reporting the *caller's* call site.  __IMPOSSIBLE__ :: HasCallStack => a-__IMPOSSIBLE__ = throwImpossible (withFileAndLine Impossible)+__IMPOSSIBLE__ = withCallerCallStack $ throwImpossible . Impossible +impossible :: HasCallStack => Impossible+impossible = withCallerCallStack Impossible+ -- | Throw an "Unreachable" error reporting the *caller's* call site. -- Note that this call to "withFileAndLine" will be filtered out -- due its filter on the srcLocModule.  __UNREACHABLE__ :: HasCallStack => a-__UNREACHABLE__ = throwImpossible (withFileAndLine Unreachable)+__UNREACHABLE__ = withCallerCallStack $ throwImpossible . Unreachable

src/full/Agda/Utils/Lens.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- -- | A cut-down implementation of lenses, with names taken from --   Edward Kmett's lens package.

src/full/Agda/Utils/List.hs view

@@ -2,11 +2,11 @@  module Agda.Utils.List where -import Control.Arrow (first, second)+import Control.Monad (filterM)  import Data.Array (Array, array, listArray) import qualified Data.Array as Array-import Data.Functor ((<$>))+import Data.Bifunctor import Data.Function import qualified Data.List as List import Data.Maybe@@ -15,6 +15,7 @@  import qualified Agda.Utils.Bag as Bag import Agda.Utils.Function (applyWhen)+import Agda.Utils.Functor  ((<.>)) import Agda.Utils.Tuple  ---------------------------------------------------------------------------@@ -71,6 +72,19 @@ lastMaybe [] = Nothing lastMaybe xs = Just $ last xs +-- | Last element (safe).  Returns a default list on empty lists.+--   O(n).+lastWithDefault :: a -> [a] -> a+lastWithDefault = last1++-- | Last element of non-empty list (safe).+--   O(n).+--   @last1 a as = last (a : as)@+last1 :: a -> [a] -> a+last1 a = \case+  [] -> a+  b:bs -> last1 b bs+ -- | Last two elements (safe). --   O(n). last2 :: [a] -> Maybe (a, a)@@ -96,15 +110,37 @@ --   O(n). initLast :: [a] -> Maybe ([a],a) initLast []     = Nothing-initLast (a:as) = Just $ loop a as where-  loop a []      = ([], a)-  loop a (b : bs) = mapFst (a:) $ loop b bs+initLast (a:as) = Just $ initLast1 a as +-- | 'init' and 'last' of non-empty list, safe.+--   O(n).+--   @initLast1 a as = (init (a:as), last (a:as)@+initLast1 :: a -> [a] -> ([a], a)+initLast1 a = \case+  []   -> ([], a)+  b:bs -> first (a:) $ initLast1 b bs++-- | 'init' of non-empty list, safe.+--   O(n).+--   @init1 a as = init (a:as)@+init1 :: a -> [a] -> [a]+init1 a = \case+  []   -> []+  b:bs -> a : init1 b bs+ -- | @init@, safe. --   O(n). initMaybe :: [a] -> Maybe [a]-initMaybe = fmap fst . initLast+initMaybe = \case+  []   -> Nothing+  a:as -> Just $ init1 a as +-- | @init@, safe.+--   O(n).+initWithDefault :: [a] -> [a] -> [a]+initWithDefault as []     = as+initWithDefault _  (a:as) = init1 a as+ --------------------------------------------------------------------------- -- * Lookup and indexing ---------------------------------------------------------------------------@@ -130,7 +166,7 @@ -- --   TODO: more efficient implementation!? findWithIndex :: (a -> Bool) -> [a] -> Maybe (a, Int)-findWithIndex p as = listToMaybe $ filter (p . fst) $ zip as [0..]+findWithIndex p as = List.find (p . fst) (zip as [0..])  -- | A generalised variant of 'elemIndex'. -- O(n).@@ -364,6 +400,7 @@ -- | A variant of 'List.groupBy' which applies the predicate to consecutive -- pairs. -- O(n).+-- DEPRECATED in favor of 'Agda.Utils.List1.groupBy''. groupBy' :: (a -> a -> Bool) -> [a] -> [[a]] groupBy' _ []           = [] groupBy' p xxs@(x : xs) = grp x $ zipWith (\x y -> (p x y, y)) xxs xs@@ -467,10 +504,29 @@ -- --   @allDuplicates xs == sort $ xs \\ nub xs@. allDuplicates :: Ord a => [a] -> [a]-allDuplicates = concat . map (drop 1 . reverse) . Bag.groups . Bag.fromList+allDuplicates = concatMap (drop 1 . reverse) . Bag.groups . Bag.fromList   -- The reverse is necessary to actually remove the *first* occurrence   -- of each element. +-- | Partition a list into first and later occurrences of elements+--   (modulo some quotient given by a representation function).+--+--  Time: O(n log n).+--+--  Specification:+--+--  > nubAndDuplicatesOn f xs = (ys, xs List.\\ ys)+--  >   where ys = nubOn f xs++nubAndDuplicatesOn :: Ord b => (a -> b) -> [a] -> ([a], [a])+nubAndDuplicatesOn f = loop Set.empty+  where+  loop s [] = ([], [])+  loop s (a:as)+    | b `Set.member` s = second (a:) $ loop s as+    | otherwise        = first  (a:) $ loop (Set.insert b s) as+    where b = f a+ -- | Efficient variant of 'nubBy' for lists, using a set to store already seen elements. -- O(n log n) --@@ -487,11 +543,6 @@     | otherwise        = a : loop (Set.insert b s) as     where b = f a --- Andreas, 2019-11-16--- The implementation of nubOn using Set can be more than 1000-times--- faster than the following old one using List.sort.--- (Tested using criterion and -O on some lists of length 100.000.)- -- -- | Efficient variant of 'nubBy' for finite lists (using sorting). -- -- O(n log n) -- --@@ -537,6 +588,13 @@ allEqual []       = True allEqual (x : xs) = all (== x) xs +-- | Non-efficient, monadic 'nub'.+-- O(n²).+nubM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a]+nubM eq = loop where+  loop []     = return []+  loop (a:as) = (a :) <$> do loop =<< filterM (not <.> eq a) as+ --------------------------------------------------------------------------- -- * Zipping ---------------------------------------------------------------------------@@ -629,3 +687,13 @@   xsA, ysA :: Array Int a   xsA = listArray (0,n-1) xs   ysA = listArray (0,m-1) ys+++mergeStrictlyOrderedBy :: (a -> a -> Bool) -> [a] -> [a] -> Maybe [a]+mergeStrictlyOrderedBy (<) = loop where+  loop [] ys = Just ys+  loop xs [] = Just xs+  loop (x:xs) (y:ys)+    | x < y = (x:) <$> loop xs (y:ys)+    | y < x = (y:) <$> loop (x:xs) ys+    | otherwise = Nothing

+ src/full/Agda/Utils/List1.hs view

@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}++-- | Non-empty lists.+--+--   Better name @List1@ for non-empty lists, plus missing functionality.+--+--   Import:+--   @+--+--     {-# LANGUAGE PatternSynonyms #-}+--+--     import           Agda.Utils.List1 (List1, pattern (:|))+--     import qualified Agda.Utils.List1 as List1+--+--   @++++{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+  -- because of https://gitlab.haskell.org/ghc/ghc/issues/10339++module Agda.Utils.List1+  ( module Agda.Utils.List1+  , module List1+  ) where++import Prelude hiding (filter)++import Control.Arrow ((&&&))+import Control.Monad (filterM)+import qualified Control.Monad as List (zipWithM, zipWithM_)++import qualified Data.Either as Either+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Data.Semigroup as Semigroup++import qualified Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty as List1 hiding (NonEmpty)++import Agda.Utils.Functor ((<.>))+import Agda.Utils.Null (Null(..))+import qualified Agda.Utils.List as List++type List1 = Data.List.NonEmpty.NonEmpty++-- | Return the last element and the rest.++initLast :: List1 a -> ([a], a)+initLast = List1.init &&& List1.last+  -- traverses twice, but does not create intermediate pairs++-- | Build a list with one element.++#if !(MIN_VERSION_base(4,15,0))+singleton :: a -> List1 a+singleton = (:| [])+#endif++-- | Append a list to a non-empty list.++append :: List1 a -> [a] -> List1 a+append (x :| xs) ys = x :| mappend xs ys++-- | Prepend a list to a non-empty list.++prepend :: [a] -> List1 a -> List1 a+prepend as bs = foldr (<|) bs as++-- | More precise type for @snoc@.++snoc :: [a] -> a -> List1 a+snoc as a = prepend as $ a :| []++-- | More precise type for 'Agda.Utils.List.groupBy''.+--+-- A variant of 'List.groupBy' which applies the predicate to consecutive+-- pairs.+-- O(n).+groupBy' :: forall a. (a -> a -> Bool) -> [a] -> [List1 a]+groupBy' _ []           = []+groupBy' p xxs@(x : xs) = grp x $ List.zipWith (\ x y -> (p x y, y)) xxs xs+  where+  grp :: a -> [(Bool,a)] -> [List1 a]+  grp x ys+    | let (xs, rest) = List.span fst ys+    = (x :| List.map snd xs) : case rest of+      []                 -> []+      ((_false, z) : zs) -> grp z zs++-- | Concatenate one or more non-empty lists.++concat :: [List1 a] -> [a]+concat = concatMap toList++-- | Like 'Data.List.union'.  Duplicates in the first list are not removed.+-- O(nm).+union :: Eq a => List1 a -> List1 a -> List1 a+union (a :| as) bs = a :| List.union as (filter (/= a) bs)++-- * Recovering non-emptyness.++ifNull :: [a] -> b -> (List1 a -> b) -> b+ifNull []       b _ = b+ifNull (a : as) _ f = f $ a :| as++ifNotNull :: [a] -> (List1 a -> b) -> b -> b+ifNotNull []       _ b = b+ifNotNull (a : as) f _ = f $ a :| as++unlessNull :: Null m => [a] -> (List1 a -> m) -> m+unlessNull []       _ = empty+unlessNull (x : xs) f = f $ x :| xs++-- * List functions with no special behavior for non-empty lists.++-- | Checks if all the elements in the list are equal. Assumes that+--   the 'Eq' instance stands for an equivalence relation.+--   O(n).+allEqual :: Eq a => List1 a -> Bool+allEqual (x :| xs) = all (== x) xs++-- | Like 'Maybe.catMaybes'.++catMaybes :: List1 (Maybe a) -> [a]+catMaybes =  Maybe.catMaybes . List1.toList++-- | Like 'List1.filter'.++mapMaybe :: (a -> Maybe b) -> List1 a -> [b]+mapMaybe f = Maybe.mapMaybe f . List1.toList++-- | Like 'Data.Either.partitionEithers'.++partitionEithers :: List1 (Either a b) -> ([a], [b])+partitionEithers = Either.partitionEithers . List1.toList++-- | Like 'Data.Either.lefts'.++lefts :: List1 (Either a b) -> [a]+lefts = Either.lefts  . List1.toList++-- | Like 'Data.Either.rights'.++rights :: List1 (Either a b) -> [b]+rights = Either.rights  . List1.toList+++-- | Non-efficient, monadic 'nub'.+-- O(n²).+nubM :: Monad m => (a -> a -> m Bool) -> List1 a -> m (List1 a)+nubM eq (a :| as) = (a :|) <$> do List.nubM eq =<< filterM (not <.> eq a) as++-- | Like 'Control.Monad.zipWithM'.++zipWithM :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m (List1 c)+zipWithM f (a :| as) (b :| bs) = (:|) <$> f a b <*> List.zipWithM f as bs++-- | Like 'Control.Monad.zipWithM'.++zipWithM_ :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m ()+zipWithM_ f (a :| as) (b :| bs) = f a b *> List.zipWithM_ f as bs

+ src/full/Agda/Utils/List2.hs view

@@ -0,0 +1,79 @@++-- | Lists of length at least 2.+--+--   Import as:+--   @+--      import Agda.Utils.List2 (List2(List2))+--      import qualified Agda.Utils.List2 as List2+--   @++module Agda.Utils.List2+  ( module Agda.Utils.List2+  , module Reexport+  ) where++import Control.DeepSeq+import Control.Monad                   ( (<=<) )++import Data.Data                       ( Data )+import qualified Data.List as List++import GHC.Exts                        ( IsList(..) )+import qualified GHC.Exts  as Reexport ( toList )++import Agda.Utils.List1                ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1++import Agda.Utils.Impossible++-- | Lists of length ≥2.+data List2 a = List2 a a [a]+  deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)++-- | Safe. O(1).+head :: List2 a -> a+head (List2 a _ _) = a++-- | Safe. O(1).+tail :: List2 a -> List1 a+tail (List2 a b cs) = b :| cs++-- | Safe. O(n).+init :: List2 a -> List1 a+init (List2 a b cs) = a :| List1.init (b :| cs)++-- | Safe. O(1).+fromListMaybe :: [a] -> Maybe (List2 a)+fromListMaybe = fromList1Maybe <=< List1.nonEmpty++-- | Safe. O(1).+fromList1Maybe :: List1 a -> Maybe (List2 a)+fromList1Maybe = \case+  (a :| b : cs) -> Just (List2 a b cs)+  _ -> Nothing++instance IsList (List2 a) where+  type Item (List2 a) = a++  -- Unsafe! O(1).+  fromList :: [a] -> List2 a+  fromList (a : b : cs) = List2 a b cs+  fromList _            = __IMPOSSIBLE__++  toList :: List2 a -> [a]+  toList (List2 a b cs) = a : b : cs++-- | Safe. O(1).+toList1 :: List2 a -> List1 a+toList1 (List2 a b cs) = a :| b : cs++-- | Unsafe!+fromList1 :: List1 a -> List2 a+fromList1 (a :| b : cs) = List2 a b cs+fromList1 _             = __IMPOSSIBLE__++break :: (a -> Bool) -> List2 a -> ([a],[a])+break p = List.break p . toList++instance NFData a => NFData (List2 a) where+  rnf (List2 a b cs) = rnf a `seq` rnf b `seq` rnf cs

src/full/Agda/Utils/ListT.hs view

@@ -1,5 +1,5 @@-{-# LANGUAGE UndecidableInstances  #-}  -- Due to limitations of funct.dep. {-# LANGUAGE CPP  #-}+{-# LANGUAGE UndecidableInstances  #-} -- Due MonadReader/MonadState fundep  -- | @ListT@ done right, --   see https://www.haskell.org/haskellwiki/ListT_done_right_alternative@@ -16,11 +16,12 @@ import Control.Monad.Reader import Control.Monad.State -#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..)) #endif  import Agda.Utils.Maybe+import Agda.Utils.Monad  -- | Lazy monadic computation of a list of results. newtype ListT m a = ListT { runListT :: m (Maybe (a, ListT m a)) }@@ -30,6 +31,10 @@ mapListT :: (m (Maybe (a, ListT m a)) -> n (Maybe (b, ListT n b))) -> ListT m a -> ListT n b mapListT f = ListT . f . runListT +-- | Inverse to 'mapListT'.+unmapListT :: (ListT m a -> ListT n b) -> m (Maybe (a, ListT m a)) -> n (Maybe (b, ListT n b))+unmapListT f = runListT . f . ListT+ -- * List operations  -- | The empty lazy list.@@ -53,14 +58,21 @@ foldListT cons nil = loop where   loop l = caseListT l nil $ \ a l' -> cons a $ loop l' +-- | Lazy monadic disjunction of lazy monadic list, effects left-to-right+anyListT :: Monad m => ListT m a -> (a -> m Bool) -> m Bool+anyListT xs f = foldListT (or2M . f) (return False) xs++-- | Lazy monadic conjunction of lazy monadic list, effects left-to-right+allListT :: Monad m => ListT m a -> (a -> m Bool) -> m Bool+allListT xs f = foldListT (and2M . f) (return True) xs+ -- | Force all values in the lazy list, effects left-to-right sequenceListT :: Monad m => ListT m a -> m [a] sequenceListT = foldListT ((<$>) . (:)) $ pure []  -- | The join operation of the @ListT m@ monad. concatListT :: Monad m => ListT m (ListT m a) -> ListT m a-concatListT = ListT . foldListT append (return Nothing)-  where append l = runListT . mappend l . ListT+concatListT = ListT . foldListT (unmapListT . mappend) (return Nothing)  -- * Monadic list operations. @@ -70,7 +82,7 @@  -- | Monadic cons. consMListT :: Monad m => m a -> ListT m a -> ListT m a-consMListT ma l = ListT $ (Just . (,l)) `liftM` ma+consMListT ma l = ListT $ (Just . (,l)) <$> ma -- consMListT ma l = runMListT $ liftM (`consListT` l) ma  -- simplification:@@ -107,11 +119,13 @@ -- Instances  instance Monad m => Semigroup (ListT m a) where-  l1 <> l2 = ListT $ foldListT cons (runListT l2) l1-    where cons a = runListT . consListT a . ListT+  l1 <> l2 = ListT $ foldListT (unmapListT . consListT) (runListT l2) l1+ instance Monad m => Monoid (ListT m a) where   mempty        = nilListT+#if !(MIN_VERSION_base(4,11,0))   mappend = (<>)+#endif  instance (Functor m, Applicative m, Monad m) => Alternative (ListT m) where   empty = mempty@@ -143,7 +157,7 @@  instance (Applicative m, MonadReader r m) => MonadReader r (ListT m) where   ask     = lift ask-  local f = ListT . local f . runListT+  local   = mapListT . local  instance (Applicative m, MonadState s m) => MonadState s (ListT m) where   get = lift get

src/full/Agda/Utils/Map.hs view

@@ -1,15 +1,34 @@+{-# LANGUAGE CPP #-}  module Agda.Utils.Map where +import Data.Functor.Compose import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) +import Agda.Utils.Functor+import Agda.Utils.Impossible +-- * Monadic map operations+---------------------------------------------------------------------------++-- | Update monadically the value at one position (must exist!).+adjustM :: (Functor f, Ord k) => (v -> f v) -> k -> Map k v -> f (Map k v)+#if MIN_VERSION_containers(0,5,8)+adjustM f = Map.alterF $ \case+  Nothing -> __IMPOSSIBLE__+  Just v  -> Just <$> f v+#else+adjustM f k m =+  f (Map.findWithDefault __IMPOSSIBLE__ k m) <&> \ v -> Map.insert k v m+#endif++-- | Wrapper for 'adjustM' for convenience.+adjustM' :: (Functor f, Ord k) => (v -> f (a, v)) -> k -> Map k v -> f (a, Map k v)+adjustM' f k = getCompose . adjustM (Compose . f) k+ -- UNUSED Liang-Ting Chen (05-07-2019)--- -- * Monadic map operations--- ------------------------------------------------------------------------------ -- data EitherOrBoth a b = L a | B a b | R b -- -- -- | Not very efficient (goes via a list), but it'll do.

src/full/Agda/Utils/Maybe.hs view

@@ -9,12 +9,11 @@     , module Data.Maybe     ) where -+import Control.Applicative import Control.Monad.Trans.Maybe  import Data.Maybe - -- * Conversion.  -- | Retain object when tag is 'True'.@@ -23,10 +22,6 @@  -- * Collection operations. --- UNUSED Liang-Ting Chen 05-07-2019--- Andreas, 2020-02-17:--- Yeah, but a useful function to have in the library nevertheless.- -- | @unionWith@ for collections of size <= 1. unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a unionMaybeWith f Nothing mb      = mb@@ -101,8 +96,8 @@ whenJust m k = caseMaybe m (return ()) k  -- | 'caseMaybe' without the 'Just' case.-whenNothing :: Monad m => Maybe a -> m () -> m ()-whenNothing m d = caseMaybe m d (\_ -> return ())+whenNothing :: Monoid m => Maybe a -> m -> m+whenNothing m d = caseMaybe m d (\_ -> mempty)  -- | 'caseMaybeM' without the 'Nothing' case. whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()@@ -110,13 +105,15 @@  -- | 'caseMaybeM' without the 'Just' case. whenNothingM :: Monad m => m (Maybe a) -> m () -> m ()-whenNothingM mm d = mm >>= (`whenNothing` d)+whenNothingM mm d = maybe d (\_ -> return ()) =<< mm  -- | Lazy version of @allJust <.> sequence@. --   (@allJust = mapM@ for the @Maybe@ monad.) --   Only executes monadic effect while @isJust@. allJustM :: Monad m => [m (Maybe a)] -> m (Maybe [a]) allJustM = runMaybeT . mapM MaybeT--- allJustM []         = return $ Just []--- allJustM (mm : mms) = caseMaybeM mm (return Nothing) $ \ a ->---   fmap (a:) <$> allJust mms++-- | Lift a maybe to an Alternative.+liftMaybe :: Alternative f => Maybe a -> f a+liftMaybe = maybe empty pure+

src/full/Agda/Utils/Maybe/Strict.hs view

@@ -4,9 +4,7 @@ -- The dependencies of strict-base-types are too heavy, -- especially since it depends on lens which we consciously ruled out. -{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE CPP #-}   {-# OPTIONS_GHC -fno-warn-orphans #-}

src/full/Agda/Utils/Monad.hs view

@@ -8,23 +8,16 @@     where  import Control.Applicative  (liftA2)-import Control.Monad hiding (mapM, forM)--import qualified Control.Monad.Fail as Fail--import Control.Monad.Identity ( Identity )+import Control.Monad.Except import Control.Monad.State  import Data.Traversable as Trav hiding (for, sequence) import Data.Foldable as Fold import Data.Maybe+import Data.Monoid +import Agda.Utils.Applicative import Agda.Utils.Either-import Agda.Utils.Except-  ( Error(strMsg)-  , MonadError(catchError, throwError)-  )- import Agda.Utils.Null (ifNotNullM)  import Agda.Utils.Impossible@@ -169,23 +162,29 @@   ifM (p x) (return []) (return [x])  -- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a])-partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a],[a])-partitionM f [] =-  pure ([], [])-partitionM f (x:xs) =-  (\ b (l, r) -> if b then (x:l, r) else (l, x:r)) <$> f x <*> partitionM f xs+partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM f xs =+  foldr+    (\x -> (<*>) ((\b (l, r) -> if b then (x : l, r) else (l, x : r)) <$> f x))+    (pure ([], []))+    xs  -- MonadPlus -----------------------------------------------------------------  -- | Translates 'Maybe' to 'MonadPlus'. fromMaybeMP :: MonadPlus m => Maybe a -> m a-fromMaybeMP = maybe mzero return+fromMaybeMP = foldA  -- | Generalises the 'catMaybes' function from lists to an arbitrary -- 'MonadPlus'. catMaybesMP :: MonadPlus m => m (Maybe a) -> m a-catMaybesMP = (>>= fromMaybeMP)+catMaybesMP = scatterMP +-- | Branch over elements of a monadic 'Foldable' data structure.+scatterMP :: (MonadPlus m, Foldable t) => m (t a) -> m a+scatterMP = (>>= foldA)++ -- Error monad ------------------------------------------------------------  -- | Finally for the 'Error' class. Errors in the finally part take@@ -209,6 +208,11 @@ tryCatch :: (MonadError e m, Functor m) => m () -> m (Maybe e) tryCatch m = (Nothing <$ m) `catchError` \ err -> return $ Just err +-- | Like 'guard', but raise given error when condition fails.++guardWithError :: MonadError e m => e -> Bool -> m ()+guardWithError e b = if b then return () else throwError e+ -- State monad ------------------------------------------------------------  -- | Bracket without failure.  Typically used to preserve state.@@ -226,11 +230,3 @@ -- | Restore state after computation. localState :: MonadState s m => m a -> m a localState = bracket_ get put---- Read ---------------------------------------------------------------------readM :: (Error e, MonadError e m, Read a) => String -> m a-readM s = case reads s of-            [(x,"")]    -> return x-            _           ->-              throwError $ strMsg $ "readM: parse error string " ++ s

src/full/Agda/Utils/Monoid.hs view

@@ -1,12 +1,14 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP  #-}  -- | More monoids.  module Agda.Utils.Monoid where +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..))-import Data.Monoid (Monoid(..))+#endif + -- | Maximum of on-negative (small) natural numbers.  newtype MaxNat = MaxNat { getMaxNat :: Int }@@ -17,6 +19,8 @@  instance Monoid MaxNat where   mempty     = 0+#if !(MIN_VERSION_base(4,11,0))   mappend    = (<>)+#endif   mconcat [] = 0   mconcat ms = maximum ms

src/full/Agda/Utils/Null.hs view

@@ -31,7 +31,7 @@ import Data.Set (Set) import qualified Data.Set as Set -import Text.PrettyPrint (Doc)+import Text.PrettyPrint (Doc, isEmpty)  import Agda.Utils.Bag (Bag) import qualified Agda.Utils.Bag as Bag@@ -54,6 +54,14 @@   empty      = (empty, empty)   null (a,b) = null a && null b +instance (Null a, Null b, Null c) => Null (a,b,c) where+  empty        = (empty, empty, empty)+  null (a,b,c) = null a && null b && null c++instance (Null a, Null b, Null c, Null d) => Null (a,b,c,d) where+  empty          = (empty, empty, empty, empty)+  null (a,b,c,d) = null a && null b && null c && null d+ instance Null ByteString where   empty = ByteString.empty   null  = ByteString.null@@ -102,7 +110,7 @@  instance Null Doc where   empty = mempty-  null  = (== mempty)+  null  = isEmpty  instance (Null (m a), Monad m) => Null (ReaderT r m a) where   empty = lift empty

src/full/Agda/Utils/Permutation.hs view

@@ -1,25 +1,27 @@-{-# LANGUAGE DeriveDataTypeable    #-}  module Agda.Utils.Permutation where  import Prelude hiding (drop, null) +import Control.DeepSeq+import Control.Monad (filterM)+ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap+import Data.Functor.Identity import qualified Data.List as List import Data.Maybe import Data.Array -import Data.Foldable (Foldable)-import Data.Traversable (Traversable)- import Data.Data (Data) -import Agda.Syntax.Position (KillRange(..))+import GHC.Generics (Generic)+ import Agda.Utils.Functor import Agda.Utils.List ((!!!)) import Agda.Utils.Null import Agda.Utils.Size+import Agda.Utils.Tuple  import Agda.Utils.Impossible @@ -35,7 +37,7 @@ --   @Perm : {m : Nat}(n : Nat) -> Vec (Fin n) m -> Permutation@ --   @m@ is the 'size' of the permutation. data Permutation = Perm { permRange :: Int, permPicks :: [Int] }-  deriving (Eq, Data)+  deriving (Eq, Data, Generic)  instance Show Permutation where   show (Perm n xs) = showx [0..n - 1] ++ " -> " ++ showx xs@@ -52,8 +54,7 @@   empty = Perm 0 []   null (Perm _ picks) = null picks -instance KillRange Permutation where-  killRange = id+instance NFData Permutation  -- | @permute [1,2,0] [x0,x1,x2] = [x1,x2,x0]@ --   More precisely, @permute indices list = sublist@, generates @sublist@@@ -140,7 +141,7 @@ --   @composeP p (invertP err p) == p@ invertP :: Int -> Permutation -> Permutation invertP err p@(Perm n xs) = Perm (size xs) $ elems tmpArray-  where tmpArray = accumArray (flip const) err (0, n-1) $ zip xs [0..]+  where tmpArray = accumArray (const id) err (0, n-1) $ zip xs [0..]  -- | Turn a possible non-surjective permutation into a surjective permutation. compactP :: Permutation -> Permutation@@ -194,11 +195,15 @@ -- | Stable topologic sort. The first argument decides whether its first --   argument is an immediate parent to its second argument. topoSort :: (a -> a -> Bool) -> [a] -> Maybe Permutation-topoSort parent xs = Perm (size xs) <$> topo g+topoSort parent xs = runIdentity $ topoSortM (\x y -> Identity $ parent x y) xs++topoSortM :: Monad m => (a -> a -> m Bool) -> [a] -> m (Maybe Permutation)+topoSortM parent xs = do+  let nodes     = zip [0..] xs+      parents x = map fst <$> filterM (\(_, y) -> parent y x) nodes+  g <- mapM (mapSndM parents) nodes+  return $ Perm (size xs) <$> topo g   where-    nodes     = zip [0..] xs-    g         = [ (n, parents x) | (n, x) <- nodes ]-    parents x = [ n | (n, y) <- nodes, parent y x ]      topo :: Eq node => [(node, [node])] -> Maybe [node]     topo [] = return []@@ -221,9 +226,6 @@   , dropFrom :: a    -- ^ Where to drop from.   }   deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)--instance KillRange a => KillRange (Drop a) where-  killRange = fmap killRange  -- | Things that support delayed dropping. class DoDrop a where

src/full/Agda/Utils/Pointer.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE DeriveDataTypeable #-}  module Agda.Utils.Pointer   ( Ptr, newPtr, derefPtr, setPtr

src/full/Agda/Utils/Pretty.hs view

@@ -8,15 +8,31 @@     , module Data.Semigroup     ) where -import Data.Int ( Int32 )+import Prelude hiding (null)+ import Data.Data (Data(..))-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Foldable as Fold+import Data.Int (Int32)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word (Word64)  import qualified Text.PrettyPrint as P-import Text.PrettyPrint hiding (TextDetails(Str), empty, (<>))+import Text.PrettyPrint hiding (TextDetails(Str), empty, (<>), sep, fsep, hsep, hcat, vcat, punctuate) import Data.Semigroup ((<>)) +import Agda.Utils.Float+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null import Agda.Utils.Size  import Agda.Utils.Impossible@@ -50,6 +66,9 @@ instance Pretty Int     where pretty = text . show instance Pretty Int32   where pretty = text . show instance Pretty Integer where pretty = text . show+instance Pretty Word64  where pretty = text . show+instance Pretty Double  where pretty = text . toStringWithoutDotZero+instance Pretty Text    where pretty = text . T.unpack  instance Pretty Char where   pretty c = text [c]@@ -62,15 +81,39 @@   pretty _ = P.empty  instance Pretty a => Pretty (Maybe a) where-  prettyPrec p Nothing  = "Nothing"-  prettyPrec p (Just x) = mparens (p > 0) $ "Just" <+> prettyPrec 10 x+  prettyPrec p Nothing  = "(nothing)"+  prettyPrec p (Just x) = prettyPrec p x  instance Pretty a => Pretty [a] where   pretty = prettyList -instance Pretty a => Pretty (NonEmpty a) where-  pretty = prettyList . NonEmpty.toList+instance Pretty a => Pretty (List1 a) where+  pretty = prettyList . List1.toList +instance Pretty IntSet where+  pretty = prettySet . IntSet.toList++instance Pretty a => Pretty (Set a) where+  pretty = prettySet . Set.toList++instance Pretty a => Pretty (IntMap a) where+  pretty = prettyMap . IntMap.toList++instance (Pretty k, Pretty v) => Pretty (Map k v) where+  pretty = prettyMap . Map.toList++-- * Generalizing the original type from list to Foldable++sep, fsep, hsep, hcat, vcat :: Foldable t => t Doc -> Doc+sep  = P.sep  . Fold.toList+fsep = P.fsep . Fold.toList+hsep = P.hsep . Fold.toList+hcat = P.hcat . Fold.toList+vcat = P.vcat . Fold.toList++punctuate :: Foldable t => Doc -> t Doc -> [Doc]+punctuate d = P.punctuate d . Fold.toList+ -- * 'Doc' utilities  pwords :: String -> [Doc]@@ -79,10 +122,30 @@ fwords :: String -> Doc fwords = fsep . pwords +-- | Separate, but only if both separees are not null.++hsepWith :: Doc -> Doc -> Doc -> Doc+hsepWith sep d1 d2+  | null d2   = d1+  | null d1   = d2+  | otherwise = d1 <+> sep <+> d2+ -- | Comma separated list, without the brackets. prettyList_ :: Pretty a => [a] -> Doc prettyList_ = fsep . punctuate comma . map pretty +-- | Pretty print a set.+prettySet :: Pretty a => [a] -> Doc+prettySet = braces . prettyList_++-- | Pretty print an association list.+prettyMap :: (Pretty k, Pretty v) => [(k,v)] -> Doc+prettyMap = braces . fsep . punctuate comma . map prettyAssign++-- | Pretty print a single association.+prettyAssign :: (Pretty k, Pretty v) => (k,v) -> Doc+prettyAssign (k, v) = sep [ prettyPrec 1 k <+> "->", nest 2 $ pretty v ]+ -- ASR (2016-12-13): In pretty >= 1.1.2.0 the below function 'mparens' -- is called 'maybeParens'. I didn't use that name due to the issue -- https://github.com/haskell/pretty/issues/40.@@ -92,6 +155,10 @@ mparens True  = parens mparens False = id +-- | Only wrap in parens if not 'empty'+parensNonEmpty :: Doc -> Doc+parensNonEmpty d = if null d then empty else parens d+ -- | @align max rows@ lays out the elements of @rows@ in two columns, -- with the second components aligned. The alignment column of the -- second components is at most @max@ characters to the right of the@@ -119,7 +186,7 @@ (<?>) :: Doc -> Doc -> Doc a <?> b = hang a 2 b --- | @pshow = text . pretty@+-- | @pshow = text . show@ pshow :: Show a => a -> Doc pshow = text . show

+ src/full/Agda/Utils/RangeMap.hs view

@@ -0,0 +1,370 @@+-- | Maps containing non-overlapping intervals.++module Agda.Utils.RangeMap+  ( IsBasicRangeMap(..)+  , several+  , PairInt(..)+  , RangeMap(..)+  , rangeMapInvariant+  , fromNonOverlappingNonEmptyAscendingList+  , insert+  , splitAt+  , insideAndOutside+  , restrictTo+  )+  where++import Prelude hiding (null, splitAt)++import Control.DeepSeq++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Data.Semigroup++import Data.Strict.Tuple (Pair(..))++import Agda.Interaction.Highlighting.Range+import Agda.Utils.List+import Agda.Utils.Null++------------------------------------------------------------------------+-- An abstraction++-- | A class that is intended to make it easy to swap between+-- different range map implementations.+--+-- Note that some 'RangeMap' operations are not included in this+-- class.++class IsBasicRangeMap a m | m -> a where++  -- | The map @'singleton' rs x@ contains the ranges from @rs@, and+  -- every position in those ranges is associated with @x@.++  singleton :: Ranges -> a -> m++  -- | Converts range maps to 'IntMap's from positions to values.++  toMap :: m -> IntMap a++  -- | Converts the map to a list. The ranges are non-overlapping and+  -- non-empty, and earlier ranges precede later ones in the list.++  toList :: m -> [(Range, a)]++  -- | Returns the smallest range covering everything in the map (or+  -- 'Nothing', if the range would be empty).+  --+  -- Note that the default implementation of this operation might be+  -- inefficient.++  coveringRange :: m -> Maybe Range+  coveringRange f = do+    min <- fst <$> IntMap.lookupMin m+    max <- fst <$> IntMap.lookupMax m+    return (Range { from = min, to = max + 1 })+    where+    m = toMap f++-- | Like 'singleton', but with several 'Ranges' instead of only one.++several ::+  (IsBasicRangeMap a hl, Monoid hl) =>+  [Ranges] -> a -> hl+several rss m = mconcat $ map (flip singleton m) rss++------------------------------------------------------------------------+-- A strict pair type++-- | A strict pair type where the first argument must be an 'Int'.+--+-- This type is included because there is no 'NFData' instance for+-- 'Pair' in the package @strict@ before version 4.++newtype PairInt a = PairInt (Pair Int a)+  deriving Show++instance NFData a => NFData (PairInt a) where+  rnf (PairInt (_ :!: y)) = rnf y++-- | Constructs a pair.++pair :: Int -> a -> PairInt a+pair x y = PairInt (x :!: y)++------------------------------------------------------------------------+-- The type++-- | Maps containing non-overlapping intervals.+--+-- The implementation does not use IntMap, because IntMap does not+-- come with a constant-time size function.+--+-- Note the invariant which 'RangeMap's should satisfy+-- ('rangeMapInvariant').++newtype RangeMap a = RangeMap+  { rangeMap :: Map Int (PairInt a)+    -- ^ The keys are starting points of ranges, and the pairs contain+    -- endpoints and values.+  }+  deriving (Show, NFData)++-- | Invariant for 'RangeMap'.+--+-- The ranges must not be empty, and they must not overlap.++rangeMapInvariant :: RangeMap a -> Bool+rangeMapInvariant f = and+  [ all rangeInvariant rs+  , all (not . null) rs+  , caseList rs True $ \ r rs' ->+      and $ zipWith (<=) (map to $ init1 r rs') (map from rs')+  ]+  where+  rs = map fst $ toList f++------------------------------------------------------------------------+-- Construction, conversion and inspection++instance Null (RangeMap a) where+  empty = RangeMap { rangeMap = Map.empty }+  null  = Map.null . rangeMap++instance IsBasicRangeMap a (RangeMap a) where+  singleton (Ranges rs) m =+    RangeMap { rangeMap = Map.fromDistinctAscList rms }+    where+    rms =+      [ (from r, pair (to r) m)+      | r <- rs+      , not (null r)+      ]++  toMap f =+    IntMap.fromList+      [ (p, m)+      | (r, m) <- toList f+      , p <- rangeToPositions r+      ]++  toList =+    map (\(f, PairInt (t :!: a)) -> (Range { from = f, to = t } , a)) .+    Map.toAscList .+    rangeMap++  coveringRange f = do+    min <- fst <$> Map.lookupMin (rangeMap f)+    max <- (\(_, PairInt (p :!: _)) -> p) <$> Map.lookupMax (rangeMap f)+    return (Range { from = min, to = max })++-- | Converts a list of pairs of ranges and values to a 'RangeMap'.+-- The ranges have to be non-overlapping and non-empty, and earlier+-- ranges have to precede later ones.++fromNonOverlappingNonEmptyAscendingList :: [(Range, a)] -> RangeMap a+fromNonOverlappingNonEmptyAscendingList =+  RangeMap .+  Map.fromDistinctAscList .+  map (\(r, m) -> (from r, pair (to r) m))++-- | The number of ranges in the map.+--+-- This function should not be exported.++size :: RangeMap a -> Int+size = Map.size . rangeMap++------------------------------------------------------------------------+-- Merging++-- | Inserts a value, along with a corresponding 'Range', into a+-- 'RangeMap'. No attempt is made to merge adjacent ranges with equal+-- values.+--+-- The function argument is used to combine values. The inserted value+-- is given as the first argument to the function.++insert :: (a -> a -> a) -> Range -> a -> RangeMap a -> RangeMap a+insert combine r m (RangeMap f)+  | null r    = RangeMap f+  | otherwise =+    case equal of+      Just (PairInt (p :!: m')) ->+        case compare (to r) p of+          EQ ->+            -- The range r matches exactly.+            RangeMap $+            Map.insert (from r) (pair p (combine m m')) f+          LT ->+            -- The range r is strictly shorter.+            RangeMap $+            Map.insert (to r) (pair p m') $+            Map.insert (from r) (pair (to r) (combine m m')) f+          GT ->+            -- The range r is strictly longer. Continue recursively.+            insert combine (Range { from = p, to = to r }) m $+            RangeMap $+            Map.insert (from r) (pair p (combine m m')) f+      Nothing ->+        -- Find the part of r that does not overlap with anything in+        -- smaller or larger, if any.+        case (overlapLeft, overlapRight) of+          (Nothing, Nothing) ->+            -- No overlap.+            RangeMap $+            Map.insert (from r) (pair (to r) m) f+          (Nothing, Just p) ->+            -- Overlap on the right. Continue recursively.+            insert combine (Range { from = p, to = to r }) m $+            RangeMap $+            Map.insert (from r) (pair p m) f+          (Just (p1, PairInt (p2 :!: m')), Just p3) ->+            -- Overlap on both sides. Continue recursively.+            insert combine (Range { from = p3, to = to r }) m $+            RangeMap $+            (if p2 == p3 then+               -- The left range ends exactly where the right range+               -- starts.+               id+             else+               -- There is something between the left and right+               -- ranges.+               Map.insert p2 (pair p3 m)) $+            Map.insert (from r) (pair p2 (combine m m')) $+            Map.insert p1 (pair (from r) m') f+          (Just (p1, PairInt (p2 :!: m')), Nothing) ->+            case compare p2 (to r) of+              LT ->+                -- Overlap on the left, the left range ends before r.+                RangeMap $+                Map.insert p2 (pair (to r) m) $+                Map.insert (from r) (pair p2 (combine m m')) $+                Map.insert p1 (pair (from r) m') f+              EQ ->+                -- Overlap on the left, the left range ends where r+                -- ends.+                RangeMap $+                Map.insert (from r) (pair (to r) (combine m m')) $+                Map.insert p1 (pair (from r) m') f+              GT ->+                -- Overlap on the left, the left range ends after r.+                RangeMap $+                Map.insert (to r) (pair p2 m') $+                Map.insert (from r) (pair (to r) (combine m m')) $+                Map.insert p1 (pair (from r) m') f+    where+    (smaller, equal, larger) = Map.splitLookup (from r) f++    overlapRight = case Map.lookupMin larger of+      Nothing -> Nothing+      Just (from, _)+        | from < to r -> Just from+        | otherwise   -> Nothing++    overlapLeft = case Map.lookupMax smaller of+      Nothing -> Nothing+      Just s@(_, PairInt (to :!: _))+        | from r < to -> Just s+        | otherwise   -> Nothing++-- | Merges 'RangeMap's by inserting every \"piece\" of the smaller+-- one into the larger one.++instance Semigroup a => Semigroup (RangeMap a) where+  f1 <> f2+    | size f1 <= size f2 =+      foldr (uncurry $ insert (<>)) f2 (toList f1)+    | otherwise =+      foldr (uncurry $ insert (flip (<>))) f1 (toList f2)++-- | Merges 'RangeMap's by inserting every \"piece\" of the smaller+-- one into the larger one.++instance Semigroup a => Monoid (RangeMap a) where+  mempty  = empty+  mappend = (<>)++------------------------------------------------------------------------+-- Splitting++-- | The value of @'splitAt' p f@ is a pair @(f1, f2)@ which contains+-- everything from @f@. All the positions in @f1@ are less than @p@,+-- and all the positions in @f2@ are greater than or equal to @p@.++splitAt :: Int -> RangeMap a -> (RangeMap a, RangeMap a)+splitAt p f = (before, after)+  where+  (before, _, after) = splitAt' p f++-- | A variant of 'splitAt'. If a range in the middle was split into+-- two pieces, then those two pieces are returned.++splitAt' ::+  Int -> RangeMap a ->+  ( RangeMap a+  , Maybe ((Int, PairInt a), (Int, PairInt a))+  , RangeMap a+  )+splitAt' p (RangeMap f) =+  case equal of+    Just r  -> ( RangeMap maybeOverlapping+               , Nothing+               , RangeMap (Map.insert p r larger)+               )+    Nothing ->+      -- Check if maybeOverlapping overlaps with p.+      case Map.maxViewWithKey maybeOverlapping of+        Nothing ->+          (empty, Nothing, RangeMap larger)+        Just ((from, PairInt (to :!: m)), smaller)+          | to <= p ->+            ( RangeMap maybeOverlapping+            , Nothing+            , RangeMap larger+            )+          | otherwise ->+            -- Here from < p < to.+            ( RangeMap (Map.insert from (pair p m) smaller)+            , Just ((from, pair p m), (p, pair to m))+            , RangeMap (Map.insert p (pair to m) larger)+            )+  where+  (maybeOverlapping, equal, larger) = Map.splitLookup p f++-- | Returns a 'RangeMap' overlapping the given range, as well as the+-- rest of the map.++insideAndOutside :: Range -> RangeMap a -> (RangeMap a, RangeMap a)+insideAndOutside r f+  | from r == to r = (empty, f)+  | otherwise      =+    ( middle+    , -- Because it takes so long to recompile Agda with all+      -- optimisations and run a benchmark no experimental+      -- verification has been made that the code below is better than+      -- reasonable variants. Perhaps it would make sense to benchmark+      -- RangeMap independently of Agda.+      if size before < size middle || size after < size middle then+        RangeMap $ Map.union (rangeMap before) (rangeMap after)+      else+        -- If the number of pieces in the middle is "small", remove+        -- the pieces from f instead of merging before and after.+        RangeMap $+        maybe id (uncurry Map.insert . snd) split1 $+        maybe id (uncurry Map.insert . fst) split2 $+        Map.difference (rangeMap f) (rangeMap middle)+    )+  where+  (beforeMiddle, split1, after) = splitAt' (to r) f+  (before, split2, middle)      = splitAt' (from r) beforeMiddle++-- | Restricts the 'RangeMap' to the given range.++restrictTo :: Range -> RangeMap a -> RangeMap a+restrictTo r = fst . insideAndOutside r

+ src/full/Agda/Utils/Semigroup.hs view

@@ -0,0 +1,20 @@+-- | Some semigroup instances used in several places++module Agda.Utils.Semigroup (+  module Data.Semigroup)+where++import Data.Semigroup ( Semigroup, (<>) )++import Control.Applicative (liftA2)++import Control.Monad.Reader (ReaderT)+import Control.Monad.State  (StateT)++instance (Applicative m, Semigroup doc) => Semigroup (ReaderT s m doc) where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)++instance (Monad m, Semigroup doc)       => Semigroup (StateT s m doc)  where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)

src/full/Agda/Utils/Singleton.hs view

@@ -3,6 +3,7 @@  module Agda.Utils.Singleton where +import Data.Semigroup (Semigroup(..)) import Data.Monoid (Endo(..))  import Data.Hashable (Hashable)@@ -11,7 +12,6 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty  import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap@@ -24,6 +24,35 @@ import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set++-- | A create-only possibly empty collection is a monoid with the possibility+--   to inject elements.++class (Semigroup coll, Monoid coll, Singleton el coll) => Collection el coll+    | coll -> el where+  fromList :: [el] -> coll+  fromList = mconcat . map singleton++instance Collection a       [a]           where fromList = id+instance Collection a       ([a] -> [a])  where fromList = (++)+instance Collection a       (Endo [a])    where fromList = Endo . fromList+instance Collection a       (Seq a)       where fromList = Seq.fromList+instance Collection Int     IntSet        where fromList = IntSet.fromList+instance Collection (Int,a) (IntMap a)    where fromList = IntMap.fromList++instance Ord a =>+         Collection a       (Set a)       where fromList = Set.fromList++instance Ord k =>+         Collection (k, a)  (Map k a)     where fromList = Map.fromList++instance (Eq a, Hashable a) =>+         Collection a       (HashSet a)   where fromList = HashSet.fromList++instance (Eq k, Hashable k) =>+         Collection (k, a)  (HashMap k a) where fromList = HashMap.fromList++-- | Overloaded @singleton@ constructor for collections.  class Singleton el coll | coll -> el where   singleton :: el -> coll

src/full/Agda/Utils/Size.hs view

@@ -8,24 +8,19 @@   , sizeThing   ) where -import Prelude hiding (null)+import Prelude hiding (null, length) +import Data.Foldable       (Foldable, length) import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)+import Data.HashSet        (HashSet)+import Data.IntMap         (IntMap)+import Data.IntSet         (IntSet) import qualified Data.IntSet as IntSet-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import qualified Data.List as List+import Data.Map            (Map)+import Data.Set            (Set)+import Data.Sequence       (Seq) +import Agda.Utils.List1    (List1) import Agda.Utils.Null  -- | The size of a collection (i.e., its length).@@ -33,30 +28,18 @@ class Sized a where   size :: a -> Int -instance Sized [a] where-  size = List.genericLength--instance Sized (IntMap a) where-  size = IntMap.size--instance Sized IntSet where-  size = IntSet.size--instance Sized (Map k a) where-  size = Map.size--instance Sized (Set a) where-  size = Set.size--instance Sized (HashMap k a) where-  size = HashMap.size--instance Sized (HashSet a) where-  size = HashSet.size--instance Sized (Seq a) where-  size = Seq.length+  default size :: (Foldable t, t b ~ a) => a -> Int+  size = length +instance Sized [a]+instance Sized (Set a)+instance Sized (HashMap k a)+instance Sized (HashSet a)+instance Sized (IntMap a)+instance Sized (List1 a)+instance Sized (Map k a)+instance Sized (Seq a)+instance Sized IntSet where size = IntSet.size  -- | Thing decorated with its size. --   The thing should fit into main memory, thus, the size is an @Int@.

src/full/Agda/Utils/SmallSet.hs view

@@ -12,9 +12,6 @@ --    import Agda.Utils.SmallSet (SmallSet) -- @ -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Agda.Utils.SmallSet   ( SmallSet()   , Ix@@ -41,6 +38,8 @@  import Prelude hiding (null) +import Control.DeepSeq+ import Data.Array.IArray (Ix, Array) import qualified Data.Array.IArray as Array import Data.Data (Data)@@ -50,7 +49,7 @@ -- | Let @n@ be the size of type @a@. type SmallSetElement a = (Bounded a, Ix a) newtype SmallSet a = SmallSet { theSmallSet :: Array a Bool }-  deriving (Eq, Ord, Show, Data)+  deriving (Eq, Ord, Show, Data, NFData)  -- * Query

src/full/Agda/Utils/String.hs view

@@ -3,16 +3,11 @@ import Control.Monad.Reader import Control.Monad.State - import Data.Char import qualified Data.List as List import Data.String ---import Agda.Interaction.Options.IORefs ( UnicodeOrAscii(..) ) import Agda.Utils.List-import Agda.Utils.Suffix ( subscriptAllowed, toSubscriptDigit )  -- | 'quote' adds double quotes around the string, replaces newline -- characters with @\n@, and escapes double quotes and backslashes@@ -67,32 +62,18 @@                      , replicate (54 - length s) '\x2014'                      ] ---- | Shows a non-negative integer using the characters ₀-₉ instead of--- 0-9 unless the user explicitly asked us to not use any unicode characters.--showIndex :: (Show i, Integral i) => i -> String-showIndex = case subscriptAllowed of-  UnicodeOk -> map toSubscriptDigit . show-  AsciiOnly -> show- -- | Adds a final newline if there is not already one.  addFinalNewLine :: String -> String addFinalNewLine "" = "\n"-addFinalNewLine s | last s == '\n' = s-                  | otherwise      = s ++ "\n"+addFinalNewLine s@(c:cs)+  | last1 c cs == '\n' = s+  | otherwise          = s ++ "\n"  -- | Indents every line the given number of steps.  indent :: Integral i => i -> String -> String indent i = unlines . map (List.genericReplicate i ' ' ++) . lines--newtype Str = Str { unStr :: String }-  deriving Eq--instance Show Str where-  show = unStr  -- | Show a number using comma to separate powers of 1,000.

src/full/Agda/Utils/Suffix.hs view

@@ -5,17 +5,9 @@  import Agda.Utils.Impossible -import Data.IORef-import qualified System.IO.Unsafe as UNSAFE-import Agda.Interaction.Options.IORefs- ------------------------------------------------------------------------ -- Subscript digits --- | Are we allowed to use unicode supscript characters?-subscriptAllowed :: UnicodeOrAscii-subscriptAllowed = UNSAFE.unsafePerformIO (readIORef unicodeOrAscii)- -- | Is the character one of the subscripts @'₀'@-@'₉'@?  isSubscriptDigit :: Char -> Bool@@ -45,8 +37,7 @@ -- | Classification of identifier variants.  data Suffix-  = NoSuffix-  | Prime     Int  -- ^ Identifier ends in @Int@ many primes.+  = Prime     Int  -- ^ Identifier ends in @Int@ many primes.   | Index     Int  -- ^ Identifier ends in number @Int@ (ordinary digits).   | Subscript Int  -- ^ Identifier ends in number @Int@ (subscript digits). @@ -54,28 +45,27 @@ --   unless users do not want us to use any unicode.  nextSuffix :: Suffix -> Suffix-nextSuffix NoSuffix      = case subscriptAllowed of-  UnicodeOk -> Subscript 1-  AsciiOnly -> Index 1 nextSuffix (Prime i)     = Prime $ i + 1 nextSuffix (Index i)     = Index $ i + 1 nextSuffix (Subscript i) = Subscript $ i + 1  -- | Parse suffix. -suffixView :: String -> (String, Suffix)+suffixView :: String -> (String, Maybe Suffix) suffixView s-    | (ps@(_:_), s') <- span (=='\'') rs         = (reverse s', Prime $ length ps)-    | (ns@(_:_), s') <- span isDigit rs          = (reverse s', Index $ read $ reverse ns)-    | (ns@(_:_), s') <- span isSubscriptDigit rs = (reverse s', Subscript $ read $+    | (ps@(_:_), s') <- span (=='\'') rs         = (reverse s', Just $ Prime $ length ps)+    | (ns@(_:_), s') <- span isDigit rs          = (reverse s', Just $ Index $ read $ reverse ns)+    | (ns@(_:_), s') <- span isSubscriptDigit rs = (reverse s', Just $ Subscript $ read $                                                       map fromSubscriptDigit $ reverse ns)-    | otherwise                                  = (s, NoSuffix)+    | otherwise                                  = (s, Nothing)     where rs = reverse s  -- | Print suffix. +renderSuffix :: Suffix -> String+renderSuffix (Prime n)     = replicate n '\''+renderSuffix (Index i)     = show i+renderSuffix (Subscript i) = map toSubscriptDigit (show i)+ addSuffix :: String -> Suffix -> String-addSuffix s NoSuffix      = s-addSuffix s (Prime n)     = s ++ replicate n '\''-addSuffix s (Index i)     = s ++ show i-addSuffix s (Subscript i) = s ++ map toSubscriptDigit (show i)+addSuffix str suffix = str ++ renderSuffix suffix

src/full/Agda/Utils/Time.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- To avoid warning on derived Integral instance for CPUTime. {-# OPTIONS_GHC -fno-warn-identities #-}@@ -14,6 +13,7 @@   , fromMilliseconds   ) where +import Control.DeepSeq import Control.Monad.Trans import qualified System.CPUTime as CPU @@ -35,7 +35,7 @@ -- | CPU time in pico (10^-12) seconds.  newtype CPUTime = CPUTime Integer-  deriving (Eq, Show, Ord, Num, Real, Enum, Integral)+  deriving (Eq, Show, Ord, Num, Real, Enum, Integral, NFData)  fromMilliseconds :: Integer -> CPUTime fromMilliseconds n = CPUTime (n * 1000000000)

src/full/Agda/Utils/Trie.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- -- | Strict tries (based on "Data.Map.Strict" and "Agda.Utils.Maybe.Strict").  module Agda.Utils.Trie@@ -14,10 +12,9 @@  import Prelude hiding (null, lookup, filter) -+import Control.DeepSeq  import Data.Function-import Data.Foldable (Foldable) import qualified Data.Maybe as Lazy import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -38,6 +35,9 @@            , Foldable            ) +instance (NFData k, NFData v) => NFData (Trie k v) where+  rnf (Trie a b) = rnf a `seq` rnf b+ -- | Empty trie. instance Null (Trie k v) where   empty = Trie Strict.Nothing Map.empty@@ -75,7 +75,7 @@ -- --   @insert = insertWith (\ new old -> new)@ insert :: (Ord k) => [k] -> v -> Trie k v -> Trie k v-insert k v t = union (singleton k v) t+insert k v t = (singleton k v) `union` t  -- | Insert with function merging new value with old value. insertWith :: (Ord k) => (v -> v -> v) -> [k] -> v -> Trie k v -> Trie k v@@ -166,4 +166,3 @@ valueAt path f t = f (lookup path t) <&> \ case   Nothing -> delete path t   Just v  -> insert path v t-

src/full/Agda/Utils/Tuple.hs view

@@ -1,5 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Agda.Utils.Tuple   ( (-*-)   , mapFst@@ -14,7 +14,7 @@   , mapPairM   , mapFstM   , mapSndM-  , List2(..)+  , Pair(..)   ) where  import Control.Arrow  ((&&&))@@ -74,9 +74,9 @@ mapSndM :: (Applicative m) => (b -> m d) -> (a,b) -> m (a,d) mapSndM f ~(a,b) = (a,) <$> f b -newtype List2 a = List2 { list2 :: (a,a) }+data Pair a = Pair a a   deriving (Eq, Functor, Foldable, Traversable) -instance Applicative List2 where-  pure a                            = List2 (a,a)-  (List2 (f,f')) <*> (List2 (a,a')) = List2 (f a, f' a')+instance Applicative Pair where+  pure a                  = Pair a a+  Pair f f' <*> Pair a a' = Pair (f a) (f' a')

src/full/Agda/Utils/TypeLevel.hs view

@@ -1,9 +1,8 @@ {-# LANGUAGE GADTs                #-} {-# LANGUAGE DataKinds            #-} {-# LANGUAGE PolyKinds            #-}-{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE KindSignatures       #-}+ -- We need undecidable instances for the definition of @Foldr@, -- and @Domains@ and @CoDomain@ using @If@ for instance. {-# LANGUAGE UndecidableInstances #-}

src/full/Agda/Utils/TypeLits.hs view

@@ -14,7 +14,7 @@   SFalse :: SBool 'False  eraseSBool :: SBool b -> Bool-eraseSBool b = case b of+eraseSBool = \case   STrue  -> True   SFalse -> False

src/full/Agda/Utils/Update.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.Utils.Update   ( ChangeT@@ -17,13 +16,17 @@   , Updater2(..)   ) where +-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail)+ import Control.Monad.Identity import Control.Monad.Trans+import Control.Monad.Trans.Control+-- NB: Control.Monad.Trans.Identity is already exported by Control.Monad.Identity+-- since version mtl 2.2.2, but this needs at least ghc 8.2.2 import Control.Monad.Trans.Identity import Control.Monad.Writer.Strict -import Data.Traversable (Traversable(..), traverse)  import Agda.Utils.Tuple @@ -38,6 +41,17 @@ newtype ChangeT m a = ChangeT { fromChangeT :: WriterT Any m a }   deriving (Functor, Applicative, Monad, MonadTrans, MonadFail, MonadIO) +-- This instance cannot be derived in older ghcs like 8.0+-- because of the associated type synonym.+-- 8.4 can derive it, but needs UndecidableInstances.+instance MonadTransControl ChangeT where+  type StT ChangeT a = (a, Any) -- StT (WriterT Any) a  would require UndecidableInstances+  liftWith f = ChangeT $ liftWith $ \ runWriterT -> f $ runWriterT . fromChangeT+  -- Andreas, 2020-04-17: these point-free variants do not seem to type check:+  -- liftWith f = ChangeT $ liftWith $ f . (. fromChangeT)+  -- liftWith = ChangeT . liftWith . (. (. fromChangeT))+  restoreT = ChangeT . restoreT+ instance Monad m => MonadChange (ChangeT m) where   tellDirty     = ChangeT $ tell $ Any True   listenDirty m = ChangeT $ do@@ -49,7 +63,7 @@ runChangeT = fmap (mapSnd getAny) . runWriterT . fromChangeT  -- | Run a 'ChangeT' computation, but ignore change flag.-execChangeT :: Functor m => ChangeT m a -> m a+execChangeT :: Functor m => ChangeT m a -> m a -- A library function, so keep execChangeT = fmap fst . runChangeT  -- | Map a 'ChangeT' computation (monad transformer action).@@ -79,6 +93,7 @@ type Change  a = ChangeT Identity a type Updater a = UpdaterT Identity a +-- NB:: Defined but not used fromChange :: Change a -> Writer Any a fromChange = fromChangeT

src/full/Agda/Utils/Warshall.hs view

@@ -21,6 +21,7 @@  import Agda.Utils.SemiRing import Agda.Utils.List (nubOn)+import Agda.Utils.Pretty as P  type Matrix a = Array (Int,Int) a @@ -60,16 +61,18 @@       return (i, es)  -- | Edge weight in the graph, forming a semi ring.-data Weight = Finite Int | Infinite-              deriving (Eq)+data Weight+  = Finite Int+  | Infinite+  deriving (Eq, Show)  inc :: Weight -> Int -> Weight inc Infinite   n = Infinite inc (Finite k) n = Finite (k + n) -instance Show Weight where-  show (Finite i) = show i-  show Infinite   = "."+instance Pretty Weight where+  pretty (Finite i) = pretty i+  pretty Infinite   = "."  instance Ord Weight where   a <= Infinite = True@@ -99,7 +102,7 @@  data Rigid = RConst Weight            | RVar RigidId-             deriving (Eq, Ord, Show)+             deriving (Eq, Ord)  type NodeId  = Int type RigidId = Int@@ -107,11 +110,11 @@ type Scope   = RigidId -> Bool -- ^ Which rigid variables a flex may be instatiated to. -instance Show Node where-  show (Flex  i) = "?" ++ show i-  show (Rigid (RVar i)) = "v" ++ show i-  show (Rigid (RConst Infinite))   = "#"-  show (Rigid (RConst (Finite n))) = show n+instance Pretty Node where+  pretty (Flex  i)                   = "?" P.<> pretty i+  pretty (Rigid (RVar i))            = "v" P.<> pretty i+  pretty (Rigid (RConst Infinite))   = "#"+  pretty (Rigid (RConst (Finite n))) = pretty n  infinite :: Rigid -> Bool infinite (RConst Infinite) = True@@ -136,11 +139,12 @@     --   If @k <= 0@ this means  @suc^(-k) v1 <= v2@     --   otherwise               @v1 <= suc^k v3@. -instance Show Constraint where-  show (NewFlex i s) = "SizeMeta(?" ++ show i ++ ")"-  show (Arc v1 k v2) | k == 0 = show v1 ++ "<=" ++ show v2-                     | k < 0  = show v1 ++ "+" ++ show (-k) ++ "<=" ++ show v2-                     | otherwise  = show v1 ++ "<=" ++ show v2 ++ "+" ++ show k+instance Pretty Constraint where+  pretty (NewFlex i s) = hcat [ "SizeMeta(?", pretty i, ")" ]+  pretty (Arc v1 k v2)+    | k == 0    = hcat [ pretty v1, "<=", pretty v2 ]+    | k < 0     = hcat [ pretty v1, "+", pretty (-k), "<=", pretty v2 ]+    | otherwise = hcat [ pretty v1, "<=", pretty v2, "+", pretty k ]  type Constraints = [Constraint] @@ -218,14 +222,14 @@   , coldescr :: Int -> c   } -instance (Show a, Show b, Show c) => Show (LegendMatrix a b c) where-  show (LegendMatrix m rd cd) =+instance (Pretty a, Pretty b, Pretty c) => Pretty (LegendMatrix a b c) where+  pretty (LegendMatrix m rd cd) =     -- first show column description     let ((r,c),(r',c')) = bounds m-    in foldr (\ j s -> "\t" ++ show (cd j) ++ s) "" [c .. c'] +++    in foldr (\ j s -> "\t" P.<> pretty (cd j) P.<> s) "" [c .. c'] P.<>     -- then output rows-       foldr (\ i s -> "\n" ++ show (rd i) ++-                foldr (\ j t -> "\t" ++ show (m!(i,j)) ++ t)+       foldr (\ i s -> "\n" P.<> pretty (rd i) P.<>+                foldr (\ j t -> "\t" P.<> pretty (m!(i,j)) P.<> t)                       s                       [c .. c'])              "" [r .. r']@@ -245,10 +249,10 @@ data SizeExpr = SizeVar RigidId Int   -- ^ e.g. x + 5               | SizeConst Weight      -- ^ a number or infinity -instance Show SizeExpr where-  show (SizeVar n 0) = show (Rigid (RVar n))-  show (SizeVar n k) = show (Rigid (RVar n)) ++ "+" ++ show k-  show (SizeConst w) = show w+instance Pretty SizeExpr where+  pretty (SizeVar n 0) = pretty (Rigid (RVar n))+  pretty (SizeVar n k) = pretty (Rigid (RVar n)) P.<> "+" P.<> pretty k+  pretty (SizeConst w) = pretty w  -- | @sizeRigid r n@ returns the size expression corresponding to @r + n@ sizeRigid :: Rigid -> Int -> SizeExpr@@ -299,12 +303,12 @@ -}  solve :: Constraints -> Maybe Solution-solve cs = -- trace (show cs) $-   -- trace (show lm0) $-    -- trace (show lm) $ -- trace (show d) $+solve cs = -- trace (prettyShow cs) $+   -- trace (prettyShow lm0) $+    -- trace (prettyShow lm) $ -- trace (prettyShow d) $      let solution = if solvable then loop1 flexs rigids emptySolution                     else Nothing-     in -- trace (show solution) $+     in -- trace (prettyShow solution) $          solution    where -- compute the graph and its transitive closure m          gr  = buildGraph cs@@ -412,6 +416,6 @@                         (True, Finite z) | z >= 0 ->                             loop2 flxs (extendSolution subst f (sizeRigid r z))                         (_, Infinite) -> loop3 (col+1) subst-                        _ -> -- trace ("unusable rigid: " ++ show r ++ " for flex " ++ show f)+                        _ -> -- trace ("unusable rigid: " ++ prettyShow r ++ " for flex " ++ prettyShow f)                               Nothing  -- NOT: loop3 (col+1) subst                      _ -> loop3 (col+1) subst

src/full/Agda/Utils/WithDefault.hs view

@@ -11,27 +11,33 @@  module Agda.Utils.WithDefault where +import Control.DeepSeq+ import Agda.Utils.TypeLits  -- We don't want to have to remember for each flag whether its default value -- is True or False. So we bake it into the representation: the flag's type -- will mention its default value as a phantom parameter. -data WithDefault (b :: Bool) = Default | Value Bool+data WithDefault (b :: Bool) = Default | Value !Bool   deriving (Eq, Show) +instance NFData (WithDefault b) where+  rnf Default   = ()+  rnf (Value _) = ()+ -- The main mode of operation of these flags, apart from setting them explicitly, -- is to toggle them one way or the other if they hadn't been already.  setDefault :: Bool -> WithDefault b -> WithDefault b-setDefault b t = case t of+setDefault b = \case   Default -> Value b-  _ -> t+  t -> t  -- Provided that the default value is a known boolean (in practice we only use -- True or False), we can collapse a potentially uninitialised value to a boolean.  collapseDefault :: KnownBool b => WithDefault b -> Bool-collapseDefault w = case w of-  Default -> boolVal w+collapseDefault = \case+  w@Default -> boolVal w   Value b -> b

src/full/Agda/Utils/Zipper.hs view

@@ -1,8 +1,6 @@-{-# LANGUAGE TypeFamilies #-}  module Agda.Utils.Zipper where -import Data.Traversable (Traversable)  class Zipper z where   type Carrier z@@ -51,4 +49,3 @@                   Nothing       -> go c2' z1'                   Just (x, z2') -> Right (x, ComposeZip z1' z2')               Left c1 -> Left c1-

src/full/Agda/Version.hs view

@@ -1,7 +1,11 @@-module Agda.Version where+module Agda.Version+  ( version+  , package+  ) where -import Data.Version-import Data.List ( intercalate, map )+import GHC.Generics ( Generic, Rep, packageName )+import Data.List ( intercalate )+import Data.Version ( Version(versionBranch) )  import qualified Paths_Agda as PA @@ -10,3 +14,12 @@ version :: String version = intercalate "." $ map show $             versionBranch PA.version++-- | This package name.+-- This is mainly intended for use in the test suites to filter ephemeral+-- hash-fingerprinted package names like @Agda-2.6.2-5ceeWeguf1QFMaHLput4zw@.++package :: String+package = packageName (undefined :: Rep AnArbitrarySymbolInThisPackage p)++data AnArbitrarySymbolInThisPackage deriving Generic

src/full/Agda/VersionCommit.hs view

@@ -1,5 +1,10 @@+{-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-} +#if __GLASGOW_HASKELL__ >= 900+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+#endif+ module Agda.VersionCommit where  import Development.GitRev@@ -7,9 +12,7 @@ import Agda.Version  versionWithCommitInfo :: String-versionWithCommitInfo = version ++ case commitInfo of-                                     Nothing   -> ""-                                     Just info -> "-" ++ info+versionWithCommitInfo = version ++ maybe "" ("-" ++) commitInfo  -- | Information about current git commit, generated at compile time commitInfo :: Maybe String@@ -19,9 +22,9 @@   where     hash = $(gitHash) -    -- | Check if any tracked files have uncommitted changes+    -- Check if any tracked files have uncommitted changes     dirty | $(gitDirtyTracked) = "-dirty"           | otherwise          = "" -    -- | Abbreviate a commit hash while keeping it unambiguous+    -- Abbreviate a commit hash while keeping it unambiguous     abbrev = take 7

src/main/Main.hs view

@@ -5,8 +5,8 @@  module Main (main) where -import qualified Agda.Main ( main )+import Agda.Main ( runAgda ) import Prelude ( IO )  main :: IO ()-main = Agda.Main.main+main = runAgda []

stack-8.0.2.yaml view

@@ -3,8 +3,19 @@ compiler-check: match-exact  extra-deps:+- ansi-terminal-0.10.3+- ansi-wl-pprint-0.6.9 - async-2.2.1+- binary-0.8.3.0+- cpphs-1.20.9+- containers-0.5.11.0+- optparse-applicative-0.15.1.0+- parallel-3.2.2.0+- random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0+- splitmix-0.1.0.3 - text-1.2.3.1-- cpphs-1.20.9+- uuid-types-1.0.3+- wcwidth-0.0.2+- text-icu-0.7.1.0

− stack-8.10.3.yaml

@@ -1,3 +0,0 @@-resolver: lts-17.1-compiler: ghc-8.10.3-compiler-check: match-exact

+ stack-8.10.5.yaml view

@@ -0,0 +1,3 @@+resolver: lts-18.0+compiler: ghc-8.10.5+compiler-check: match-exact

stack-8.2.2.yaml view

@@ -4,7 +4,14 @@  extra-deps: - async-2.2.1+- binary-0.8.3.0+- cpphs-1.20.9+- containers-0.5.11.0+- random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0+- splitmix-0.1.0.3 - text-1.2.3.1-- cpphs-1.20.9+- uuid-types-1.0.3+- wcwidth-0.0.2+- text-icu-0.7.1.0

stack-8.4.4.yaml view

@@ -3,7 +3,10 @@ compiler-check: match-exact  extra-deps:+- cpphs-1.20.9+- random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0-- cpphs-1.20.9-+- splitmix-0.1.0.3+- uuid-types-1.0.3+- text-icu-0.7.1.0

stack-8.6.5.yaml view

@@ -3,10 +3,14 @@ compiler-check: match-exact  extra-deps:+- STMonadTrans-0.4.3+- cpphs-1.20.9 - data-hash-0.2.0.1 - equivalence-0.3.4 - geniplate-mirror-0.7.6+- random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0-- STMonadTrans-0.4.3-- cpphs-1.20.9+- splitmix-0.1.0.3+- uuid-types-1.0.3+- text-icu-0.7.1.0

− stack-8.8.3.yaml

@@ -1,11 +0,0 @@-resolver: lts-16.5-compiler: ghc-8.8.3-compiler-check: match-exact--extra-deps:-- STMonadTrans-0.4.4-- cpphs-1.20.9-- data-hash-0.2.0.1-- equivalence-0.3.5-- geniplate-mirror-0.7.6-- text-icu-0.7.0.1

stack-8.8.4.yaml view

@@ -1,3 +1,8 @@ resolver: lts-16.31 compiler: ghc-8.8.4 compiler-check: match-exact++extra-deps:+- random-1.2.0+- splitmix-0.1.0.3+- text-icu-0.7.1.0

+ stack-9.0.1.yaml view

@@ -0,0 +1,93 @@+resolver: ghc-9.0.1+compiler: ghc-9.0.1+compiler-check: match-exact++extra-deps:+- aeson-1.5.6.0+- alex-3.2.6+- async-2.2.3+- bifunctors-5.5.11+- blaze-html-0.9.1.2+- boxes-0.1.5+- case-insensitive-1.2.1.0+- data-hash-0.2.0.1+- edit-distance-0.2.2.1+- equivalence-0.3.5+- gitrev-1.3.1+- happy-1.20.0+- hashable-1.3.1.0+- hashtables-1.2.4.1+- monad-control-1.0.2.3+- murmur-hash-0.1.0.9+- parallel-3.2.2.0+- regex-tdfa-1.3.1.0+- split-0.2.3.4+- strict-0.4.0.1+- unordered-containers-0.2.13.0+- uri-encode-1.5.0.7+- zlib-0.6.2.3+- STMonadTrans-0.4.5+- assoc-1.0.2+# - attoparsec-0.14.1 # no matching version for this in resolver+- attoparsec-0.13.2.5+- base-compat-0.11.2+- base-compat-batteries-0.11.2+- base-orphans-0.8.4+- blaze-builder-0.4.2.1+- blaze-markup-0.8.2.8+- comonad-5.0.8+- data-fix-0.3.1+- dlist-1.0+- fail-4.9.0.0+- network-uri-2.6.4.1+- primitive-0.7.1.0+- random-1.2.0+- regex-base-0.94.0.1+- scientific-0.3.6.2+- tagged-0.8.6.1+- th-abstraction-0.4.2.0+- these-1.1.1.1+- time-compat-1.9.5+- transformers-base-0.4.5.2+- transformers-compat-0.6.6+- utf8-string-1.0.2+- uuid-types-1.0.4+- vector-0.12.3.0+- distributive-0.6.2.1+- indexed-traversable-0.1.1+- integer-logarithms-1.0.3.1+- splitmix-0.1.0.3+- th-compat-0.1.2+- filemanip-0.3.6.3+- process-extras-0.7.4+- temporary-1.3+- unix-compat-0.5.3+- ListLike-4.7.4+- ansi-terminal-0.11+- call-stack-0.3.0+- clock-0.8.2+- data-default-0.7.1.1+- generic-deriving-1.14+- optparse-applicative-0.16.1.0+- unbounded-delays-0.1.1.1+- wcwidth-0.0.2+- ansi-wl-pprint-0.6.9+- colour-2.3.5+- data-default-class-0.1.2.0+- data-default-instances-containers-0.0.1+- data-default-instances-dlist-0.0.1+- data-default-instances-old-locale-0.0.1+- fmlist-0.9.4+- old-locale-1.0.0.7+- text-icu-0.7.1.0++# extra deps for cpphs flag+- cpphs-1.20.9.1+- polyparse-1.13++# extra deps for Windows+- mintty-0.1.2++flags:+  transformers-compat:+    five-three: true