diff --git a/src/Init/Control/EState.lean b/src/Init/Control/EState.lean index a4cb381c3f..f30c10e3fa 100644 --- a/src/Init/Control/EState.lean +++ b/src/Init/Control/EState.lean @@ -92,9 +92,6 @@ fun s => match x s with | Result.error e s => Result.error (f e) s | Result.ok a s => Result.ok a s -instance monadExceptAdapter {ε ε' σ} : MonadExceptAdapter ε ε' (EStateM ε σ) (EStateM ε' σ) := -⟨fun α f x => adaptExcept f x⟩ - @[inline] protected def bind (x : EStateM ε σ α) (f : α → EStateM ε σ β) : EStateM ε σ β := fun s => match x s with | Result.ok a s => f a s diff --git a/src/Init/Control/Except.lean b/src/Init/Control/Except.lean index 00a19af948..782c2724a7 100644 --- a/src/Init/Control/Except.lean +++ b/src/Init/Control/Except.lean @@ -178,27 +178,6 @@ catch t₁ $ fun e₁ => catch t₂ $ fun e₂ => throw (if useFirstEx then e₁ end MonadExcept -/-- Adapt a Monad stack, changing its top-most error Type. - - Note: This class can be seen as a simplification of the more "principled" definition - ``` - class MonadExceptFunctor (ε ε' : outParam (Type u)) (n n' : Type u → Type u) := - (map {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ExceptT ε m α → ExceptT ε' m α) → n α → n' α) - `` -/ -class MonadExceptAdapter (ε ε' : outParam (Type u)) (m m' : Type u → Type v) := -(adaptExcept {α : Type u} : (ε → ε') → m α → m' α) -export MonadExceptAdapter (adaptExcept) - -section -variables {ε ε' : Type u} {m m' : Type u → Type v} - -instance monadExceptAdapterTrans {n n' : Type u → Type v} [MonadExceptAdapter ε ε' m m'] [MonadFunctor m m' n n'] : MonadExceptAdapter ε ε' n n' := -⟨fun α f => monadMap (fun α => (adaptExcept f : m α → m' α))⟩ - -instance [Monad m] : MonadExceptAdapter ε ε' (ExceptT ε m) (ExceptT ε' m) := -⟨fun α => ExceptT.adapt⟩ -end - @[inline] def observing {ε α : Type u} {m : Type u → Type v} [Monad m] [MonadExcept ε m] (x : m α) : m (Except ε α) := catch (do a ← x; pure (Except.ok a)) (fun ex => pure (Except.error ex)) diff --git a/src/Init/System/IO.lean b/src/Init/System/IO.lean index 66ea37958c..513c6e1bb3 100644 --- a/src/Init/System/IO.lean +++ b/src/Init/System/IO.lean @@ -28,9 +28,6 @@ def IO.RealWorld : Type := Unit -/ def EIO (ε : Type) : Type → Type := EStateM ε IO.RealWorld -instance {ε ε'} : MonadExceptAdapter ε ε' (EIO ε) (EIO ε') := - inferInstanceAs $ MonadExceptAdapter ε ε' (EStateM ε IO.RealWorld) (EStateM ε' IO.RealWorld) - @[inline] def EIO.catchExceptions {α ε} (x : EIO ε α) (h : ε → EIO Empty α) : EIO Empty α := fun s => match x s with | EStateM.Result.ok a s => EStateM.Result.ok a s @@ -84,9 +81,6 @@ instance (m n) [MonadIO m] [MonadLift m n] : MonadIO n := instance : MonadIO IO := { liftIO := id } -@[inline] def mkEIOMonadIO {ε ε'} [MonadIO (EIO ε)] (f : ε → ε') : MonadIO (EIO ε') := - { liftIO := fun x => adaptExcept f (liftIO x : EIO ε _) } - namespace IO def ofExcept {ε α : Type} [HasToString ε] (e : Except ε α) : IO α := diff --git a/src/Lean/CoreM.lean b/src/Lean/CoreM.lean index 286447c324..3c5b35fbb5 100644 --- a/src/Lean/CoreM.lean +++ b/src/Lean/CoreM.lean @@ -63,7 +63,7 @@ instance : MonadRecDepth CoreM := { @[inline] def liftIOCore {α} (x : IO α) : CoreM α := do let ref ← getRef - liftM (adaptExcept (fun (err : IO.Error) => Exception.error ref (toString err)) x : EIO Exception α) + IO.toEIO (fun (err : IO.Error) => Exception.error ref (toString err)) x instance : MonadIO CoreM := { liftIO := @liftIOCore @@ -97,7 +97,7 @@ def mkFreshUserName {m} [MonadLiftT CoreM m] (n : Name) : m Name := instance {α} [MetaHasEval α] : MetaHasEval (CoreM α) := { eval := fun env opts x _ => do let x : CoreM α := do try x finally printTraces - let (a, s) ← x.toIO { maxRecDepth := getMaxRecDepth opts, options := opts } { env := env} + let (a, s) ← x.toIO { maxRecDepth := getMaxRecDepth opts, options := opts } { env := env } MetaHasEval.eval s.env opts a (hideUnit := true) } @@ -106,17 +106,17 @@ end Core export Core (CoreM mkFreshUserName) @[inline] def catchInternalId {α} {m : Type → Type} [Monad m] [MonadExcept Exception m] (id : InternalExceptionId) (x : m α) (h : Exception → m α) : m α := do -try - x -catch ex => match ex with - | Exception.error _ _ => throw ex - | Exception.internal id' => if id == id' then h ex else throw ex + try + x + catch ex => match ex with + | Exception.error _ _ => throw ex + | Exception.internal id' => if id == id' then h ex else throw ex @[inline] def catchInternalIds {α} {m : Type → Type} [Monad m] [MonadExcept Exception m] (ids : List InternalExceptionId) (x : m α) (h : Exception → m α) : m α := do -try - x -catch ex => match ex with - | Exception.error _ _ => throw ex - | Exception.internal id => if ids.contains id then h ex else throw ex + try + x + catch ex => match ex with + | Exception.error _ _ => throw ex + | Exception.internal id => if ids.contains id then h ex else throw ex end Lean diff --git a/src/Lean/Elab/Command.lean b/src/Lean/Elab/Command.lean index e2dc009421..bdcc04970a 100644 --- a/src/Lean/Elab/Command.lean +++ b/src/Lean/Elab/Command.lean @@ -115,7 +115,7 @@ private def ioErrorToMessage (ctx : Context) (ref : Syntax) (err : IO.Error) : M @[inline] def liftIO {α} (x : IO α) : CommandElabM α := do let ctx ← read - liftEIO $ adaptExcept (fun (ex : IO.Error) => Exception.error ctx.ref ex.toString) x + IO.toEIO (fun (ex : IO.Error) => Exception.error ctx.ref ex.toString) x instance : MonadIO CommandElabM := { liftIO := liftIO } diff --git a/src/Lean/PrettyPrinter.lean b/src/Lean/PrettyPrinter.lean index 1f547fc618..a7eb5035f6 100644 --- a/src/Lean/PrettyPrinter.lean +++ b/src/Lean/PrettyPrinter.lean @@ -44,14 +44,19 @@ parenthesize Lean.Parser.Module.module.parenthesizer stx >>= format Lean.Parser. private partial def noContext : MessageData → MessageData | MessageData.withContext ctx msg => noContext msg +| MessageData.withNamingContext ctx msg => MessageData.withNamingContext ctx (noContext msg) +| MessageData.nest n msg => MessageData.nest n (noContext msg) +| MessageData.group msg => MessageData.group (noContext msg) +| MessageData.compose msg₁ msg₂ => MessageData.compose (noContext msg₁) (noContext msg₂) +| MessageData.tagged tag msg => MessageData.tagged tag (noContext msg) +| MessageData.node msgs => MessageData.node (msgs.map noContext) | msg => msg -- strip context (including environments with registered pretty printers) to prevent infinite recursion when pretty printing pretty printer error -private def withoutContext {m} [MonadExceptAdapter Exception Exception m m] (x : m Format) : m Format := -adaptExcept (fun ex => match ex with - | Exception.error ref msg => Exception.error ref (noContext msg) - | e => e) - x +private def withoutContext {m} [MonadExcept Exception m] (x : m Format) : m Format := +«catch» x fun + | Exception.error ref msg => throw $ Exception.error ref (noContext msg) + | ex => throw ex builtin_initialize ppFnsRef.set { diff --git a/src/Lean/Server/Snapshots.lean b/src/Lean/Server/Snapshots.lean index b988e743e3..24383d8f95 100644 --- a/src/Lean/Server/Snapshots.lean +++ b/src/Lean/Server/Snapshots.lean @@ -92,11 +92,10 @@ def compileNextCmd (contents : String) (snap : Snapshot) : IO (Sum Snapshot Mess fileName := inputCtx.fileName, fileMap := inputCtx.fileMap } - adaptExcept - ioErrorFromEmpty - (Elab.Command.catchExceptions + EIO.toIO ioErrorFromEmpty $ + Elab.Command.catchExceptions (Elab.Command.elabCommand cmdStx) - cmdCtx cmdStateRef) + cmdCtx cmdStateRef let postCmdState ← cmdStateRef.get let postCmdSnap : Snapshot := { beginPos := cmdPos,