refactor: rename mkMonadicType to mkMonadApp (#13800)
This PR renames the `do` elaborator's `mkMonadicType` to `mkMonadApp`, aligning it with the existing `mkPureApp` / `mkBindApp` naming convention in `DoOps`. Co-authored-by: Sebastian Graf <sg@lean-fro.org>
This commit is contained in:
parent
ada1696f04
commit
da8bcf7916
9 changed files with 26 additions and 26 deletions
|
|
@ -185,7 +185,7 @@ open Lean.Meta
|
||||||
if info.returnsEarly then
|
if info.returnsEarly then
|
||||||
let ret ← getFVarFromUserName returnVarName
|
let ret ← getFVarFromUserName returnVarName
|
||||||
let ret ← if loopMutVars.isEmpty then mkAppM ``Prod.fst #[ret] else pure ret
|
let ret ← if loopMutVars.isEmpty then mkAppM ``Prod.fst #[ret] else pure ret
|
||||||
let motive := mkLambda `_ .default (← inferType ret) (← mkMonadicType γ)
|
let motive := mkLambda `_ .default (← inferType ret) (← mkMonadApp γ)
|
||||||
let app := mkApp3 (mkConst ``Break.runK.match_1 [mi.u, mi.v.succ]) oldReturnCont.resultType motive ret
|
let app := mkApp3 (mkConst ``Break.runK.match_1 [mi.u, mi.v.succ]) oldReturnCont.resultType motive ret
|
||||||
let none := mkSimpleThunk (← dec.continueWithUnit)
|
let none := mkSimpleThunk (← dec.continueWithUnit)
|
||||||
let some ← withLocalDeclD (← mkFreshUserName `r) oldReturnCont.resultType fun r => do
|
let some ← withLocalDeclD (← mkFreshUserName `r) oldReturnCont.resultType fun r => do
|
||||||
|
|
|
||||||
|
|
@ -54,7 +54,7 @@ where
|
||||||
-- elaborator. However, for Lake.Package.mkBuildArchiveFacetConfig, we still need to postpone.
|
-- elaborator. However, for Lake.Package.mkBuildArchiveFacetConfig, we still need to postpone.
|
||||||
doElabToSyntax "then branch of if with condition {cond}" (elabDoSeq thenSeq dec) fun then_ => do
|
doElabToSyntax "then branch of if with condition {cond}" (elabDoSeq thenSeq dec) fun then_ => do
|
||||||
doElabToSyntax "else branch of if with condition {cond}" (elabDoSeq elseSeq dec) fun else_ => do
|
doElabToSyntax "else branch of if with condition {cond}" (elabDoSeq elseSeq dec) fun else_ => do
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
Term.elabTermEnsuringType (← `(if $cond then $then_ else $else_)) mγ
|
Term.elabTermEnsuringType (← `(if $cond then $then_ else $else_)) mγ
|
||||||
|
|
||||||
elabDite h cond thenSeq elseSeq dec := do
|
elabDite h cond thenSeq elseSeq dec := do
|
||||||
|
|
@ -62,7 +62,7 @@ where
|
||||||
elabDoSeq (if then_ then thenSeq else elseSeq) dec
|
elabDoSeq (if then_ then thenSeq else elseSeq) dec
|
||||||
doElabToSyntax "then branch of if with condition {cond}" (elabDiteBranch true) fun then_ => do
|
doElabToSyntax "then branch of if with condition {cond}" (elabDiteBranch true) fun then_ => do
|
||||||
doElabToSyntax "else branch of if with condition {cond}" (elabDiteBranch false) fun else_ => do
|
doElabToSyntax "else branch of if with condition {cond}" (elabDiteBranch false) fun else_ => do
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
match h with
|
match h with
|
||||||
| `(_%$tk) => Term.elabTermEnsuringType (← `(if _%$tk : $cond then $then_ else $else_)) mγ
|
| `(_%$tk) => Term.elabTermEnsuringType (← `(if _%$tk : $cond then $then_ else $else_)) mγ
|
||||||
| `($h:ident) => Term.elabTermEnsuringType (← `(if $h:ident : $cond then $then_ else $else_)) mγ
|
| `($h:ident) => Term.elabTermEnsuringType (← `(if $h:ident : $cond then $then_ else $else_)) mγ
|
||||||
|
|
|
||||||
|
|
@ -95,7 +95,7 @@ partial def elabDoLetOrReassign (config : Term.LetConfig) (letOrReassign : LetOr
|
||||||
let dec ← dec.ensureUnitAt tk
|
let dec ← dec.ensureUnitAt tk
|
||||||
-- Some decl preprocessing on the patterns and expected types:
|
-- Some decl preprocessing on the patterns and expected types:
|
||||||
let decl ← pushTypeIntoReassignment letOrReassign decl
|
let decl ← pushTypeIntoReassignment letOrReassign decl
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
match decl with
|
match decl with
|
||||||
| `(letDecl| $decl:letEqnsDecl) =>
|
| `(letDecl| $decl:letEqnsDecl) =>
|
||||||
let declNew ← `(letDecl| $(⟨← liftMacroM <| Term.expandLetEqnsDecl decl⟩):letIdDecl)
|
let declNew ← `(letDecl| $(⟨← liftMacroM <| Term.expandLetEqnsDecl decl⟩):letIdDecl)
|
||||||
|
|
@ -221,7 +221,7 @@ private def getLetConfigAndCheckMut (letConfigStx : TSyntax ``Parser.Term.letCon
|
||||||
let `(doLetRec| let%$tk rec $decls:letRecDecls) := stx | throwUnsupportedSyntax
|
let `(doLetRec| let%$tk rec $decls:letRecDecls) := stx | throwUnsupportedSyntax
|
||||||
let dec ← dec.ensureUnitAt tk
|
let dec ← dec.ensureUnitAt tk
|
||||||
let vars ← getLetRecDeclsVars decls
|
let vars ← getLetRecDeclsVars decls
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
doElabToSyntax m!"let rec body of group {vars}" dec.continueWithUnit fun body => do
|
doElabToSyntax m!"let rec body of group {vars}" dec.continueWithUnit fun body => do
|
||||||
-- Let recs may never have nested actions. We expand just for the sake of error messages.
|
-- Let recs may never have nested actions. We expand just for the sake of error messages.
|
||||||
-- This suppresses error messages for the let body. Not sure if this is a good call, but it was
|
-- This suppresses error messages for the let body. Not sure if this is a good call, but it was
|
||||||
|
|
|
||||||
|
|
@ -26,9 +26,9 @@ open Lean.Meta.Match
|
||||||
private def elabDoSeqWithRefinedType (type : Expr) (doSeq : TSyntax ``doSeq) (dec : DoElemCont) : DoElabM Expr := do
|
private def elabDoSeqWithRefinedType (type : Expr) (doSeq : TSyntax ``doSeq) (dec : DoElemCont) : DoElabM Expr := do
|
||||||
let newDoBlockResultType ← withNewMCtxDepth do
|
let newDoBlockResultType ← withNewMCtxDepth do
|
||||||
let γ ← mkFreshExprMVar (mkSort (← read).monadInfo.u.succ)
|
let γ ← mkFreshExprMVar (mkSort (← read).monadInfo.u.succ)
|
||||||
unless ← isDefEqGuarded type (← mkMonadicType γ) do
|
unless ← isDefEqGuarded type (← mkMonadApp γ) do
|
||||||
throwError "Could not determine dependently-refined result type of `do` block.\n
|
throwError "Could not determine dependently-refined result type of `do` block.\n
|
||||||
Expected type {type} was not def eq to {← mkMonadicType γ}"
|
Expected type {type} was not def eq to {← mkMonadApp γ}"
|
||||||
instantiateMVars γ
|
instantiateMVars γ
|
||||||
trace[Elab.do.match] "newDoBlockResultType: {newDoBlockResultType}"
|
trace[Elab.do.match] "newDoBlockResultType: {newDoBlockResultType}"
|
||||||
-- The `doBlockResultType` *is* the continuation's return type, since it is duplicable.
|
-- The `doBlockResultType` *is* the continuation's return type, since it is duplicable.
|
||||||
|
|
@ -47,7 +47,7 @@ The rest of the code in this file is concerned with providing the default, non-d
|
||||||
private def expandToTermMatch : DoElab := fun stx dec => do
|
private def expandToTermMatch : DoElab := fun stx dec => do
|
||||||
let `(doMatch| match $[(dependent := $dep?)]? $[(generalizing := $gen?)]? $[(motive := $motive?)]? $discrs:matchDiscr,* with $alts:matchAlt*) := stx | throwUnsupportedSyntax
|
let `(doMatch| match $[(dependent := $dep?)]? $[(generalizing := $gen?)]? $[(motive := $motive?)]? $discrs:matchDiscr,* with $alts:matchAlt*) := stx | throwUnsupportedSyntax
|
||||||
let doBlockResultType := (← read).doBlockResultType
|
let doBlockResultType := (← read).doBlockResultType
|
||||||
let mγ ← mkMonadicType doBlockResultType
|
let mγ ← mkMonadApp doBlockResultType
|
||||||
-- trace[Elab.do] "expandToTermMatch. mγ: {mγ}, dec.resultType: {dec.resultType}, dec.duplicable: {dec.kind matches .duplicable ..}"
|
-- trace[Elab.do] "expandToTermMatch. mγ: {mγ}, dec.resultType: {dec.resultType}, dec.duplicable: {dec.kind matches .duplicable ..}"
|
||||||
let info ← inferControlInfoElem stx
|
let info ← inferControlInfoElem stx
|
||||||
let dependent := dep?.getD ⟨.missing⟩ matches `(trueVal| true)
|
let dependent := dep?.getD ⟨.missing⟩ matches `(trueVal| true)
|
||||||
|
|
@ -183,7 +183,7 @@ private def elabMatchAlt (discrs : Array Term.Discr) (matchType : Expr)
|
||||||
|
|
||||||
private def elabMatchAlts (discrs : Array Term.Discr) (alts : Array DoMatchAltView) (dec : DoElemCont) : DoElabM (Expr × Array AltLHS × Array Expr) := do
|
private def elabMatchAlts (discrs : Array Term.Discr) (alts : Array DoMatchAltView) (dec : DoElemCont) : DoElabM (Expr × Array AltLHS × Array Expr) := do
|
||||||
let alts ← liftMacroM <| Term.expandMacrosInPatterns alts
|
let alts ← liftMacroM <| Term.expandMacrosInPatterns alts
|
||||||
let matchType ← mkDepMatchMotive discrs (← mkMonadicType (← read).doBlockResultType)
|
let matchType ← mkDepMatchMotive discrs (← mkMonadApp (← read).doBlockResultType)
|
||||||
let (lhss, rhss) ← Array.unzip <$> alts.mapM (elabMatchAlt discrs matchType · dec)
|
let (lhss, rhss) ← Array.unzip <$> alts.mapM (elabMatchAlt discrs matchType · dec)
|
||||||
return (matchType, lhss, rhss)
|
return (matchType, lhss, rhss)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -60,6 +60,6 @@ where elabDoMatchExprNoMeta (info : ControlInfo) (discr : Term) (alts : TSyntax
|
||||||
doElabToSyntax m!"match_expr else alternative" (ref := elseSeq) (elabDoSeq ⟨elseSeq⟩ dec) fun rhs => do
|
doElabToSyntax m!"match_expr else alternative" (ref := elseSeq) (elabDoSeq ⟨elseSeq⟩ dec) fun rhs => do
|
||||||
let alts : TSyntax ``matchExprAlts := ⟨alts.raw.modifyArg 0 fun node => node.setArgs altsArr⟩
|
let alts : TSyntax ``matchExprAlts := ⟨alts.raw.modifyArg 0 fun node => node.setArgs altsArr⟩
|
||||||
let alts : TSyntax ``matchExprAlts := ⟨alts.raw.modifyArg 1 (·.setArg 3 rhs)⟩
|
let alts : TSyntax ``matchExprAlts := ⟨alts.raw.modifyArg 1 (·.setArg 3 rhs)⟩
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
Term.elabTerm (← `(match_expr $discr with $alts)) mγ
|
Term.elabTerm (← `(match_expr $discr with $alts)) mγ
|
||||||
elabMatch 0 (alts.raw[0].getArgs.map (⟨·⟩))
|
elabMatch 0 (alts.raw[0].getArgs.map (⟨·⟩))
|
||||||
|
|
|
||||||
|
|
@ -24,7 +24,7 @@ open InternalSyntax in
|
||||||
|
|
||||||
@[builtin_doElem_elab Lean.Parser.Term.doExpr] def elabDoExpr : DoElab := fun stx dec => do
|
@[builtin_doElem_elab Lean.Parser.Term.doExpr] def elabDoExpr : DoElab := fun stx dec => do
|
||||||
let `(doExpr| $e:term) := stx | throwUnsupportedSyntax
|
let `(doExpr| $e:term) := stx | throwUnsupportedSyntax
|
||||||
let mα ← mkMonadicType dec.resultType
|
let mα ← mkMonadApp dec.resultType
|
||||||
let e ← Term.elabTermEnsuringType e mα
|
let e ← Term.elabTermEnsuringType e mα
|
||||||
dec.mkBindUnlessPure e
|
dec.mkBindUnlessPure e
|
||||||
|
|
||||||
|
|
@ -39,21 +39,21 @@ open InternalSyntax in
|
||||||
|
|
||||||
@[builtin_doElem_elab Lean.Parser.Term.doDbgTrace] def elabDoDbgTrace : DoElab := fun stx dec => do
|
@[builtin_doElem_elab Lean.Parser.Term.doDbgTrace] def elabDoDbgTrace : DoElab := fun stx dec => do
|
||||||
let `(doDbgTrace| dbg_trace%$tk $msg:term) := stx | throwUnsupportedSyntax
|
let `(doDbgTrace| dbg_trace%$tk $msg:term) := stx | throwUnsupportedSyntax
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let dec ← dec.ensureUnitAt tk
|
let dec ← dec.ensureUnitAt tk
|
||||||
doElabToSyntax "dbg_trace body" dec.continueWithUnit fun body => do
|
doElabToSyntax "dbg_trace body" dec.continueWithUnit fun body => do
|
||||||
Term.elabTerm (← `(dbg_trace $msg; $body)) mγ
|
Term.elabTerm (← `(dbg_trace $msg; $body)) mγ
|
||||||
|
|
||||||
@[builtin_doElem_elab Lean.Parser.Term.doAssert] def elabDoAssert : DoElab := fun stx dec => do
|
@[builtin_doElem_elab Lean.Parser.Term.doAssert] def elabDoAssert : DoElab := fun stx dec => do
|
||||||
let `(doAssert| assert!%$tk $cond) := stx | throwUnsupportedSyntax
|
let `(doAssert| assert!%$tk $cond) := stx | throwUnsupportedSyntax
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let dec ← dec.ensureUnitAt tk
|
let dec ← dec.ensureUnitAt tk
|
||||||
doElabToSyntax "assert! body" dec.continueWithUnit fun body => do
|
doElabToSyntax "assert! body" dec.continueWithUnit fun body => do
|
||||||
Term.elabTerm (← `(assert! $cond; $body)) mγ
|
Term.elabTerm (← `(assert! $cond; $body)) mγ
|
||||||
|
|
||||||
@[builtin_doElem_elab Lean.Parser.Term.doDebugAssert] def elabDoDebugAssert : DoElab := fun stx dec => do
|
@[builtin_doElem_elab Lean.Parser.Term.doDebugAssert] def elabDoDebugAssert : DoElab := fun stx dec => do
|
||||||
let `(doDebugAssert| debug_assert!%$tk $cond) := stx | throwUnsupportedSyntax
|
let `(doDebugAssert| debug_assert!%$tk $cond) := stx | throwUnsupportedSyntax
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let dec ← dec.ensureUnitAt tk
|
let dec ← dec.ensureUnitAt tk
|
||||||
doElabToSyntax "debug_assert! body" dec.continueWithUnit fun body => do
|
doElabToSyntax "debug_assert! body" dec.continueWithUnit fun body => do
|
||||||
Term.elabTerm (← `(debug_assert! $cond; $body)) mγ
|
Term.elabTerm (← `(debug_assert! $cond; $body)) mγ
|
||||||
|
|
|
||||||
|
|
@ -225,7 +225,7 @@ unsafe def ContInfoRef.toContInfoImpl (m : ContInfoRef) : ContInfo :=
|
||||||
opaque ContInfoRef.toContInfo (m : ContInfoRef) : ContInfo
|
opaque ContInfoRef.toContInfo (m : ContInfoRef) : ContInfo
|
||||||
|
|
||||||
/-- Constructs `m α` from `α`. -/
|
/-- Constructs `m α` from `α`. -/
|
||||||
def mkMonadicType (resultType : Expr) : DoElabM Expr :=
|
def mkMonadApp (resultType : Expr) : DoElabM Expr :=
|
||||||
return mkApp (← read).monadInfo.m resultType
|
return mkApp (← read).monadInfo.m resultType
|
||||||
|
|
||||||
/-- The cached `PUnit` expression. -/
|
/-- The cached `PUnit` expression. -/
|
||||||
|
|
@ -469,7 +469,7 @@ the bind if `$(← dec.k)` is `pure $dec.resultName` or `e` is some `pure` compu
|
||||||
-/
|
-/
|
||||||
def DoElemCont.mkBindUnlessPure (dec : DoElemCont) (e : Expr) : DoElabM Expr := do
|
def DoElemCont.mkBindUnlessPure (dec : DoElemCont) (e : Expr) : DoElabM Expr := do
|
||||||
-- let eResultTy ← mkFreshResultType
|
-- let eResultTy ← mkFreshResultType
|
||||||
-- let e ← Term.ensureHasType (← mkMonadicType eResultTy) e
|
-- let e ← Term.ensureHasType (← mkMonadApp eResultTy) e
|
||||||
-- let dec ← dec.ensureHasType eResultTy
|
-- let dec ← dec.ensureHasType eResultTy
|
||||||
let x := dec.resultName
|
let x := dec.resultName
|
||||||
let k := dec.k
|
let k := dec.k
|
||||||
|
|
@ -505,7 +505,7 @@ def DoElemCont.mkBindUnlessPure (dec : DoElemCont) (e : Expr) : DoElabM Expr :=
|
||||||
-- else -- would be too aggressive
|
-- else -- would be too aggressive
|
||||||
-- return ← mapLetDecl (nondep := true) (kind := declKind) x eResultTy eRes fun _ => k ref
|
-- return ← mapLetDecl (nondep := true) (kind := declKind) x eResultTy eRes fun _ => k ref
|
||||||
|
|
||||||
let body ← Term.ensureHasType (← mkMonadicType kResultTy) body
|
let body ← Term.ensureHasType (← mkMonadApp kResultTy) body
|
||||||
let k ← mkLambdaFVars #[xFVar] body
|
let k ← mkLambdaFVars #[xFVar] body
|
||||||
mkBindApp eResultTy kResultTy e k
|
mkBindApp eResultTy kResultTy e k
|
||||||
|
|
||||||
|
|
@ -603,7 +603,7 @@ def DoElemCont.withDuplicableCont (nondupDec : DoElemCont) (callerInfo : Control
|
||||||
if nondupDec.kind matches .duplicable .. then
|
if nondupDec.kind matches .duplicable .. then
|
||||||
return ← caller nondupDec
|
return ← caller nondupDec
|
||||||
let γ := (← read).doBlockResultType
|
let γ := (← read).doBlockResultType
|
||||||
let mγ ← mkMonadicType γ
|
let mγ ← mkMonadApp γ
|
||||||
let mutVars := (← read).mutVars |>.filter (callerInfo.reassigns.contains ·.getId)
|
let mutVars := (← read).mutVars |>.filter (callerInfo.reassigns.contains ·.getId)
|
||||||
let mutVarNames := mutVars.map (·.getId)
|
let mutVarNames := mutVars.map (·.getId)
|
||||||
let joinName ← mkFreshUserName `__do_jp
|
let joinName ← mkFreshUserName `__do_jp
|
||||||
|
|
@ -869,7 +869,7 @@ private def elabDoElemFns (stx : TSyntax `doElem) (cont : DoElemCont)
|
||||||
match fns with
|
match fns with
|
||||||
| [] => throwError "unexpected `do` element syntax{indentD stx}"
|
| [] => throwError "unexpected `do` element syntax{indentD stx}"
|
||||||
| elabFn :: elabFns =>
|
| elabFn :: elabFns =>
|
||||||
let expectedType ← mkMonadicType (← read).doBlockResultType
|
let expectedType ← mkMonadApp (← read).doBlockResultType
|
||||||
withTermInfoContext' elabFn.declName stx (expectedType := expectedType) do
|
withTermInfoContext' elabFn.declName stx (expectedType := expectedType) do
|
||||||
try
|
try
|
||||||
elabFn.value stx cont
|
elabFn.value stx cont
|
||||||
|
|
@ -897,7 +897,7 @@ partial def elabDoElem (stx : TSyntax `doElem) (cont : DoElemCont) (catchExPostp
|
||||||
checkSystem "do element elaborator"
|
checkSystem "do element elaborator"
|
||||||
profileitM Exception "do element elaborator" (decl := k) (← getOptions) <|
|
profileitM Exception "do element elaborator" (decl := k) (← getOptions) <|
|
||||||
withRef stx <| withIncRecDepth <| withFreshMacroScope <| do
|
withRef stx <| withIncRecDepth <| withFreshMacroScope <| do
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
if (← read).deadCode matches .deadSyntactically then
|
if (← read).deadCode matches .deadSyntactically then
|
||||||
logWarningAt stx "This `do` element and its control-flow region are dead code. Consider removing it."
|
logWarningAt stx "This `do` element and its control-flow region are dead code. Consider removing it."
|
||||||
return ← mkFreshExprMVar mγ (userName := `deadCode)
|
return ← mkFreshExprMVar mγ (userName := `deadCode)
|
||||||
|
|
@ -940,7 +940,7 @@ partial def elabDoSeq (doSeq : TSyntax ``doSeq) (cont : DoElemCont) (catchExPost
|
||||||
| .internal id _ =>
|
| .internal id _ =>
|
||||||
if catchExPostpone && id == postponeExceptionId then
|
if catchExPostpone && id == postponeExceptionId then
|
||||||
s.restore
|
s.restore
|
||||||
let expectedType ← mkMonadicType (← read).doBlockResultType
|
let expectedType ← mkMonadApp (← read).doBlockResultType
|
||||||
doElabToSyntax m!"do sequence {doSeq}" (elabDoSeq doSeq cont) (Term.postponeElabTerm · expectedType)
|
doElabToSyntax m!"do sequence {doSeq}" (elabDoSeq doSeq cont) (Term.postponeElabTerm · expectedType)
|
||||||
else
|
else
|
||||||
throw ex
|
throw ex
|
||||||
|
|
|
||||||
|
|
@ -89,7 +89,7 @@ def ControlStack.optionT (baseMonadInfo : MonadInfo) (optionTWrapper casesOnWrap
|
||||||
mkLambdaFVars #[r] (← outerCont)
|
mkLambdaFVars #[r] (← outerCont)
|
||||||
let ksuccess ← withLocalDeclD dec.resultName dec.resultType fun r => do
|
let ksuccess ← withLocalDeclD dec.resultName dec.resultType fun r => do
|
||||||
mkLambdaFVars #[r] (← dec.k)
|
mkLambdaFVars #[r] (← dec.k)
|
||||||
let β ← mkMonadicType (← read).doBlockResultType
|
let β ← mkMonadApp (← read).doBlockResultType
|
||||||
return mkApp5 (mkConst casesOnWrapper [baseMonadInfo.u, baseMonadInfo.v]) dec.resultType β e kexit ksuccess
|
return mkApp5 (mkConst casesOnWrapper [baseMonadInfo.u, baseMonadInfo.v]) dec.resultType β e kexit ksuccess
|
||||||
base.restoreCont { resultName, resultType, k }
|
base.restoreCont { resultName, resultType, k }
|
||||||
where
|
where
|
||||||
|
|
@ -150,7 +150,7 @@ def ControlStack.mkBreak (base : ControlStack) (hasContinue : Bool) : DoElabM Ex
|
||||||
-- When there's an outer `continue` layer as well, we account for that by applying `stM` of
|
-- When there's an outer `continue` layer as well, we account for that by applying `stM` of
|
||||||
-- `OptionT` to `α`.
|
-- `OptionT` to `α`.
|
||||||
let α := if hasContinue then mkApp (mkConst ``Option [mi.u]) α else α
|
let α := if hasContinue then mkApp (mkConst ``Option [mi.u]) α else α
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let res ← base.runInBase <| mkApp3 (mkConst ``BreakT.break [mi.u, mi.v]) α mi.m inst
|
let res ← base.runInBase <| mkApp3 (mkConst ``BreakT.break [mi.u, mi.v]) α mi.m inst
|
||||||
let ty ← inferType res
|
let ty ← inferType res
|
||||||
-- Now instantiate `α`
|
-- Now instantiate `α`
|
||||||
|
|
@ -161,7 +161,7 @@ def ControlStack.mkContinue (base : ControlStack) : DoElabM Expr := do
|
||||||
let mi := { (← read).monadInfo with m := (← base.m) }
|
let mi := { (← read).monadInfo with m := (← base.m) }
|
||||||
let inst ← mkInstMonad mi
|
let inst ← mkInstMonad mi
|
||||||
let α ← mkFreshResultType `α
|
let α ← mkFreshResultType `α
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let res ← base.runInBase <| mkApp3 (mkConst ``ContinueT.continue [mi.u, mi.v]) α mi.m inst
|
let res ← base.runInBase <| mkApp3 (mkConst ``ContinueT.continue [mi.u, mi.v]) α mi.m inst
|
||||||
let ty ← inferType res
|
let ty ← inferType res
|
||||||
-- Now instantiate `α`
|
-- Now instantiate `α`
|
||||||
|
|
@ -173,7 +173,7 @@ def ControlStack.mkReturn (base : ControlStack) (r : Expr) : DoElabM Expr := do
|
||||||
let instMonad ← mkInstMonad mi
|
let instMonad ← mkInstMonad mi
|
||||||
let ρ ← inferType r
|
let ρ ← inferType r
|
||||||
let δ ← mkFreshResultType `δ
|
let δ ← mkFreshResultType `δ
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let mγ' := mkApp mi.m (mkApp2 (mkConst ``Except [mi.u, mi.v]) ρ δ)
|
let mγ' := mkApp mi.m (mkApp2 (mkConst ``Except [mi.u, mi.v]) ρ δ)
|
||||||
synthUsingDefEq "early return result type" mγ mγ'
|
synthUsingDefEq "early return result type" mγ mγ'
|
||||||
base.runInBase <| mkApp5 (mkConst ``EarlyReturnT.return [mi.u, mi.v]) ρ mi.m δ instMonad r
|
base.runInBase <| mkApp5 (mkConst ``EarlyReturnT.return [mi.u, mi.v]) ρ mi.m δ instMonad r
|
||||||
|
|
|
||||||
|
|
@ -365,7 +365,7 @@ def elabIdbgTerm : TermElab := fun stx expectedType? => do
|
||||||
@[builtin_doElem_elab Lean.Parser.Term.doIdbg]
|
@[builtin_doElem_elab Lean.Parser.Term.doIdbg]
|
||||||
def elabDoIdbg : DoElab := fun stx dec => do
|
def elabDoIdbg : DoElab := fun stx dec => do
|
||||||
let `(Lean.Parser.Term.doIdbg| idbg%$tk $e) := stx | throwUnsupportedSyntax
|
let `(Lean.Parser.Term.doIdbg| idbg%$tk $e) := stx | throwUnsupportedSyntax
|
||||||
let mγ ← mkMonadicType (← read).doBlockResultType
|
let mγ ← mkMonadApp (← read).doBlockResultType
|
||||||
let dec ← dec.ensureUnitAt tk
|
let dec ← dec.ensureUnitAt tk
|
||||||
doElabToSyntax "idbg body" dec.continueWithUnit fun body => do
|
doElabToSyntax "idbg body" dec.continueWithUnit fun body => do
|
||||||
elabIdbgCore (e := e) (body := body) (ref := stx) mγ
|
elabIdbgCore (e := e) (body := body) (ref := stx) mγ
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue