261dc999d0
@kha I was working in the new declaration type and using tasks there.
Since we don't have tasks yet in Lean, I decided to start refactoring
the `thunk` type. I defined it as:
```
-- TODO(Leo): mark as opaque, it is implemented by the new runtime
structure thunk (α : Type u) : Type u :=
(fn : unit → α)
def thunk.pure {α : Type u} (a : α) : thunk α :=
⟨λ _, a⟩
def thunk.get {α : Type u} (t : thunk α) : α :=
t.fn ()
```
The idea is to use the runtime primitives to implement them.
Then, I realized the support for `thunk`s in the elaborator are quite
hacky. Given `f x`, if `f`'s domain has type `thunk A`, we elaborate
`f x` as `f (fun _, x)` even if `x` has type `thunk A`.
This is quite bad, for example, suppose we have
```
def f (x : thunk A) := ...
```
Then, the following definition is type incorrect.
```
def g (x : thunk A) := f x
```
and we are forced to write
```
def g (x : thunk A) := f (x ())
```
The term `f (x ())` will be elaborated as `f (fun _, x ())` and an
unnecessary closure is created at runtime.
This mechanism inherited from Lean 3 is also incompatible with the
new thunk definition. Given `x : thunk A`, I want to write `x.get`
to retrieve the value instead of `x ()` as in Lean 3.
However, `x.get` expands into the nonsensical `(fun _, x).get`.
So, I decided to view the mapping `A` to `thunk A` as a "coercion".
I used double quotes, because it is a macro instead of a function.
If it were a coercion, then we would be using `thunk.pure` to coerce
values but this is not we want most of the time.
For example, given `f : thunk A -> B` and a term `t : A`, when we write
`f t`, we want it to be converted into `f (fun _, t)` instead of
`f (thunk.pure t)` which would eagerly compute `t`. The transformation
`t` into `fun _, t` is syntactic.
We cannot implement it using type classes. I implemented it as
a hard-coded extra case like the one from `Prop` to `bool`.
We can also add a coercion from `thunk A` to `A` to avoid the `.get`.
That being said, I had a few breakages in the code base since we only
use coercions when the given and expected type do not contain
metavariables.
84 lines
2.4 KiB
Text
84 lines
2.4 KiB
Text
/-
|
||
Copyright (c) 2018 Microsoft Corporation. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Sebastian Ullrich
|
||
-/
|
||
prelude
|
||
import init.lean.format init.data.rbmap init.lean.pos init.lean.name init.lean.options
|
||
|
||
universe u
|
||
|
||
namespace lean
|
||
|
||
inductive message
|
||
| from_format (fmt : format)
|
||
|
||
instance : has_coe format message :=
|
||
⟨message.from_format⟩
|
||
|
||
inductive trace
|
||
| mk (msg : message) (subtraces : list trace)
|
||
|
||
def trace.pp : trace → format
|
||
| (trace.mk (message.from_format fmt) subtraces) :=
|
||
fmt ++ format.nest 2 (format.join $ subtraces.map (λ t, format.line ++ t.pp))
|
||
|
||
namespace trace
|
||
|
||
def trace_map := rbmap pos trace (<)
|
||
|
||
structure trace_state :=
|
||
(opts : options)
|
||
(roots : trace_map)
|
||
(cur_pos : option pos)
|
||
(cur_traces : list trace)
|
||
|
||
def trace_t (m : Type → Type u) := state_t trace_state m
|
||
local attribute [reducible] trace_t
|
||
|
||
instance (m) [monad m] : monad (trace_t m) := infer_instance
|
||
|
||
class monad_tracer (m : Type → Type u) :=
|
||
(trace_root {α} : pos → name → message → thunk (m α) → m α)
|
||
(trace_ctx {α} : name → message → thunk (m α) → m α)
|
||
|
||
export monad_tracer (trace_root trace_ctx)
|
||
|
||
def trace {m} [monad m] [monad_tracer m] (cls : name) (msg : message) : m unit :=
|
||
trace_ctx cls msg (pure () : m unit)
|
||
|
||
instance (m) [monad m] : monad_tracer (trace_t m) :=
|
||
{ trace_root := λ α pos cls msg ctx, do {
|
||
st ← get,
|
||
if st.opts.get_bool cls = some tt then do {
|
||
modify $ λ st, {cur_pos := pos, cur_traces := [], ..st},
|
||
a ← ctx.get,
|
||
modify $ λ (st : trace_state), {roots := st.roots.insert pos ⟨msg, st.cur_traces⟩, ..st},
|
||
pure a
|
||
} else ctx.get
|
||
},
|
||
trace_ctx := λ α cls msg ctx, do {
|
||
st ← get,
|
||
-- tracing enabled?
|
||
some _ ← pure st.cur_pos | ctx.get,
|
||
-- trace class enabled?
|
||
if st.opts.get_bool cls = some tt then do {
|
||
put {cur_traces := [], ..st},
|
||
a ← ctx.get,
|
||
modify $ λ (st' : trace_state), {cur_traces := st.cur_traces ++ [⟨msg, st'.cur_traces⟩], ..st'},
|
||
pure a
|
||
} else
|
||
-- disable tracing inside 'ctx'
|
||
adapt_state'
|
||
(λ _, {cur_pos := none, ..st})
|
||
(λ st', {cur_pos := st.cur_pos, ..st'})
|
||
ctx.get
|
||
}
|
||
}
|
||
|
||
meta def trace_t.run {m α} [monad m] (opts : options) (x : trace_t m α) : m (α × trace_map) :=
|
||
do (a, st) ← state_t.run x {opts := opts, roots := mk_rbmap _ _ _, cur_pos := none, cur_traces := []},
|
||
pure (a, st.roots)
|
||
|
||
end trace
|
||
end lean
|