diff --git a/examples/contract.golden b/examples/contract.golden index 2e003d5d..b163b06b 100644 --- a/examples/contract.golden +++ b/examples/contract.golden @@ -1,5 +1,5 @@ -# : (Syntax → Syntax) -# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) -# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) -# : ∀(α : *). (α → α) +# : (Syntax → Syntax) +# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) +# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) +# : ∀(α : *). (α → α) (true) : Bool diff --git a/examples/datatypes.golden b/examples/datatypes.golden index 5ce50eeb..07495cd3 100644 --- a/examples/datatypes.golden +++ b/examples/datatypes.golden @@ -3,9 +3,9 @@ (add1 (add1 (add1 (add1 (zero))))) : Nat (right (true)) : ∀(α : *). (Either α Bool) (left (:: (add1 (zero)) (nil))) : ∀(α : *). (Either (List Nat) α) -# : (Nat → (Nat → Nat)) +# : (Nat → (Nat → Nat)) (add1 (add1 (add1 (add1 (add1 (zero)))))) : Nat -# : (Alphabet → Integer) -# : (Alphabet → Bool) +# : (Alphabet → Integer) +# : (Alphabet → Bool) (true) : Bool (false) : Bool diff --git a/examples/error.golden b/examples/error.golden index 2f715be2..7a8bb500 100644 --- a/examples/error.golden +++ b/examples/error.golden @@ -1 +1 @@ -# : ∀(α : *). (Syntax → α) +# : ∀(α : *). (Syntax → α) diff --git a/examples/eta-case.golden b/examples/eta-case.golden index a7d403f3..4796258b 100644 --- a/examples/eta-case.golden +++ b/examples/eta-case.golden @@ -10,11 +10,11 @@ #[eta-case.kl:225.13-225.20]<((eta-case-aux ...) (::))> : Syntax #[eta-case.kl:243.19-243.22] <(eta-case-aux (list 1 2 3) (::) (pair) ((nil) (pair 0 (nil))))> : Syntax -# : ∀(α : *). (α → ((List α) → (List α))) -# : ((List Integer) → (List Integer)) +# : ∀(α : *). (α → ((List α) → (List α))) +# : ((List Integer) → (List Integer)) (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) -# : ∀(α : *). (α → ((List α) → (List α))) -# : ((List Integer) → (List Integer)) +# : ∀(α : *). (α → ((List α) → (List α))) +# : ((List Integer) → (List Integer)) (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) diff --git a/examples/fix.golden b/examples/fix.golden index 01f89732..16de42ea 100644 --- a/examples/fix.golden +++ b/examples/fix.golden @@ -1,7 +1,7 @@ (in (cons "hello" (in (cons "world" (in (nil)))))) : (Fix (ListF String)) (in (cons "hello" (in (cons "world" (in (nil)))))) : (Fix (ListF String)) (in (succ (in (succ (in (zero)))))) : (Fix NatF) -# : ∀(α : *) (β : *). ((α → β) → ((Fix (ListF α)) → (Fix (ListF β)))) +# : ∀(α : *) (β : *). ((α → β) → ((Fix (ListF α)) → (Fix (ListF β)))) (in (cons (in (succ (in (succ (in (zero)))))) (in (cons (in (succ (in (succ (in (succ (in (zero)))))))) (in (nil)))))) : (Fix (ListF (Fix NatF))) diff --git a/examples/higher-kinded.golden b/examples/higher-kinded.golden index 094e34b5..c09a887b 100644 --- a/examples/higher-kinded.golden +++ b/examples/higher-kinded.golden @@ -1,7 +1,7 @@ (of-unit #) : (OfUnit IO) -(of-unit #) : (OfUnit (→ Unit)) +(of-unit #) : (OfUnit (→ Unit)) (of-unit (just (unit))) : (OfUnit Maybe) (of-unit (pair (unit) (unit))) : (OfUnit (Pair Unit)) -(of-unit-unit #) : (OfUnitUnit (→)) -(of-unit-unit #) : (OfUnitUnit (→)) +(of-unit-unit #) : (OfUnitUnit (→)) +(of-unit-unit #) : (OfUnitUnit (→)) (of-unit-unit (pair (unit) (unit))) : (OfUnitUnit Pair) diff --git a/examples/implicit-conversion-test.golden b/examples/implicit-conversion-test.golden index 900459ae..29156fc6 100644 --- a/examples/implicit-conversion-test.golden +++ b/examples/implicit-conversion-test.golden @@ -1,5 +1,5 @@ 42 : Integer 4 : Integer "4!" : String -# : (Integer → Integer) +# : (Integer → Integer) "31!" : String diff --git a/examples/monad.golden b/examples/monad.golden index 502d2f90..1df5f6f7 100644 --- a/examples/monad.golden +++ b/examples/monad.golden @@ -1,14 +1,14 @@ -# : ∀(α : *). (α → α) -# : ∀(α : (* → *)) (β : *) (γ : *). ((Functor α β γ) → ((β → γ) → ((α β) → (α γ)))) -(applicative (functor #) # #) : ∀(α : *) (β : *). (Applicative Macro α β) -# : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → (β → (α β))) -# : ∀(α : (* → *)) (β : *) (γ : *). +# : ∀(α : *). (α → α) +# : ∀(α : (* → *)) (β : *) (γ : *). ((Functor α β γ) → ((β → γ) → ((α β) → (α γ)))) +(applicative (functor #) # #) : ∀(α : *) (β : *). (Applicative Macro α β) +# : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → (β → (α β))) +# : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → ((α (β → γ)) → ((α β) → (α γ)))) (just "applicative notation") : (Maybe String) (nothing) : (Maybe String) (just "applicative notation") : (Maybe String) (nothing) : (Maybe String) -# : ∀(α : (* → *)) (β : *) (γ : *). +# : ∀(α : (* → *)) (β : *) (γ : *). ((Monad α β γ) → ((α β) → ((β → (α γ)) → (α γ)))) (just "hey") : (Maybe String) (just "hey") : (Maybe String) diff --git a/examples/non-examples/bad-lexical-env.golden b/examples/non-examples/bad-lexical-env.golden new file mode 100644 index 00000000..dd828932 --- /dev/null +++ b/examples/non-examples/bad-lexical-env.golden @@ -0,0 +1 @@ +Unknown: #[bad-lexical-env.kl:3.24-3.25] diff --git a/examples/non-examples/bad-lexical-env.kl b/examples/non-examples/bad-lexical-env.kl new file mode 100644 index 00000000..20ec281c --- /dev/null +++ b/examples/non-examples/bad-lexical-env.kl @@ -0,0 +1,6 @@ +#lang kernel + +(define f (lambda (ff) y)) +(define g (lambda (y) (f))) + +(example (g 2)) diff --git a/examples/non-examples/error.golden b/examples/non-examples/error.golden index 4059bbee..85cc52bc 100644 --- a/examples/non-examples/error.golden +++ b/examples/non-examples/error.golden @@ -1 +1,4 @@ -Error at phase p0: error.kl:3.18-3.34: "It went wrong." +Error at phase p0: + error.kl:3.18-3.34: "It went wrong." + stack trace: + ---- Halt diff --git a/examples/non-examples/stack-traces/.#error-in-cons-head.golden b/examples/non-examples/stack-traces/.#error-in-cons-head.golden new file mode 100644 index 00000000..eecce1f1 --- /dev/null +++ b/examples/non-examples/stack-traces/.#error-in-cons-head.golden @@ -0,0 +1 @@ +User error; no such file: "/home/doyougnu/programming/klister/examples/non-examples/stack-traces/doyougnu@7thChamber.38408:1735135986" diff --git a/examples/non-examples/stack-traces/error-in-arg.golden b/examples/non-examples/stack-traces/error-in-arg.golden new file mode 100644 index 00000000..327846fc --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-arg.golden @@ -0,0 +1,5 @@ +Error at phase p0: + error-in-arg.kl:5.24-5.27: bad + stack trace: + ---- with function # + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-arg.kl b/examples/non-examples/stack-traces/error-in-arg.kl new file mode 100644 index 00000000..c0df6821 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-arg.kl @@ -0,0 +1,5 @@ +#lang "prelude.kl" + +(define fail (lambda (thing) (+ thing 1))) + +(example (fail (error 'bad))) diff --git a/examples/non-examples/stack-traces/error-in-bind-head.golden b/examples/non-examples/stack-traces/error-in-bind-head.golden new file mode 100644 index 00000000..9296adce --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-head.golden @@ -0,0 +1,7 @@ +Error at phase p0: + error-in-bind-head.kl:3.29-3.30: e + stack trace: + ---- in pure macro + ---- in bind macro head + λx. pure x + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-bind-head.kl b/examples/non-examples/stack-traces/error-in-bind-head.kl new file mode 100644 index 00000000..ddb84ede --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-head.kl @@ -0,0 +1,3 @@ +#lang "prelude.kl" + +(example (>>= (pure (error 'e)) (lambda (x) (pure x)))) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.golden b/examples/non-examples/stack-traces/error-in-bind-tail.golden new file mode 100644 index 00000000..01d413cf --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-tail.golden @@ -0,0 +1 @@ +pure #[error-in-bind-tail.kl:4.15-4.28] >>= # : ∀(α : *). (Macro α) diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.kl b/examples/non-examples/stack-traces/error-in-bind-tail.kl new file mode 100644 index 00000000..9d1e2ab3 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-tail.kl @@ -0,0 +1,8 @@ +#lang "prelude.kl" + +(example + (>>= (pure 'hello-go-boom) + (lambda (x) + (>>= (pure x) + -- TODO: why doesn't this work? + (lambda (y) (error y)))))) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-case-constructor.golden b/examples/non-examples/stack-traces/error-in-case-constructor.golden new file mode 100644 index 00000000..77fd034a --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-case-constructor.golden @@ -0,0 +1,5 @@ +Error at phase p0: + error-in-case-constructor.kl:12.20-12.31: Im-an-error + stack trace: + ---- in data case pattern: l + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-case-constructor.kl b/examples/non-examples/stack-traces/error-in-case-constructor.kl new file mode 100644 index 00000000..8af01be9 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-case-constructor.kl @@ -0,0 +1,15 @@ +#lang "prelude.kl" + +(import "lambda-case.kl") + +(datatype (Alphabet) + (a) (b) (c) (d) (e) (f) (g) (h) (i) (j) (k) (l) (m) (n) + (o) (p) (q) (r) (s) (t) (u) (v) (x) (y) (z) (æ) (ø) (å)) + +(define fail + (lambda (thing) + (case thing + [(l) (error 'Im-an-error)] + [(else the-other) the-other]))) + +(example (fail (l))) diff --git a/examples/non-examples/stack-traces/error-in-cons-head.golden b/examples/non-examples/stack-traces/error-in-cons-head.golden new file mode 100644 index 00000000..171cd460 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-cons-head.golden @@ -0,0 +1 @@ +Unknown: #[error-in-cons-head.kl:8.6-8.9] diff --git a/examples/non-examples/stack-traces/error-in-cons-head.kl b/examples/non-examples/stack-traces/error-in-cons-head.kl new file mode 100644 index 00000000..0c8336ae --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-cons-head.kl @@ -0,0 +1,10 @@ +#lang "prelude.kl" + +(import "lambda-case.kl") + +-- TODO: DYG: how to test the pairs? +(define fail + (lambda (thing) + (car '(1 2 'something-else)))) + +(example (fail 3)) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-constructor.golden b/examples/non-examples/stack-traces/error-in-constructor.golden new file mode 100644 index 00000000..634a282f --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-constructor.golden @@ -0,0 +1,7 @@ +Error at phase p0: + error-in-constructor.kl:17.45-17.56: Im-an-error + stack trace: + ---- in constructor pair + in field 2 + ---- in let #[error-in-constructor.kl:17.22-17.24] + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-constructor.kl b/examples/non-examples/stack-traces/error-in-constructor.kl new file mode 100644 index 00000000..588e4615 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-constructor.kl @@ -0,0 +1,20 @@ +#lang "prelude.kl" + +(import "lambda-case.kl") + +(datatype (Pair A B) + (pair A B)) + +(define fst + (lambda-case + [(pair x _) x])) + +(define snd + (lambda-case + [(pair _ y) y])) + +(define fail (lambda (thing) + (let (go (pair thing (error 'Im-an-error))) + go))) + +(example (fail 23)) diff --git a/examples/non-examples/stack-traces/error-in-let.golden b/examples/non-examples/stack-traces/error-in-let.golden new file mode 100644 index 00000000..c6e35fef --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-let.golden @@ -0,0 +1,6 @@ +Error at phase p0: + error-in-let.kl:4.42-4.53: Im-an-error + stack trace: + ---- with function # + ---- in let #[error-in-let.kl:4.22-4.24] + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-let.kl b/examples/non-examples/stack-traces/error-in-let.kl new file mode 100644 index 00000000..86d27bbc --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-let.kl @@ -0,0 +1,7 @@ +#lang "prelude.kl" + +(define fail (lambda (thing) + (let (go (+ thing (error 'Im-an-error))) + go))) + +(example (fail 23)) diff --git a/examples/non-examples/stack-traces/error-in-list.golden b/examples/non-examples/stack-traces/error-in-list.golden new file mode 100644 index 00000000..52a17384 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-list.golden @@ -0,0 +1,4 @@ +Error at phase p0: + error-in-list.kl:7.27-7.38: Im-an-error + stack trace: + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-list.kl b/examples/non-examples/stack-traces/error-in-list.kl new file mode 100644 index 00000000..e21db5e8 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-list.kl @@ -0,0 +1,13 @@ +#lang "prelude.kl" + +(import "defun.kl") +(import "list.kl") + +(define thing 'nothing) +(define the-error (error 'Im-an-error)) + +(defun fail (thing) (+ 1 thing)) + +-- TODO: DYG: how to test +-- (example `(list-syntax (,thing (fail the-error) ()) thing)) +(example `('a 'b ,the-error)) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-pure-macro.golden b/examples/non-examples/stack-traces/error-in-pure-macro.golden new file mode 100644 index 00000000..fb32fe25 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-pure-macro.golden @@ -0,0 +1,5 @@ +Error at phase p0: + error-in-pure-macro.kl:3.24-3.38: surprise-error + stack trace: + ---- in pure macro + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-pure-macro.kl b/examples/non-examples/stack-traces/error-in-pure-macro.kl new file mode 100644 index 00000000..80eee47a --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-pure-macro.kl @@ -0,0 +1,3 @@ +#lang "prelude.kl" + +(example (pure (error 'surprise-error))) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/in-arg-error.golden b/examples/non-examples/stack-traces/in-arg-error.golden new file mode 100644 index 00000000..fa38ecbe --- /dev/null +++ b/examples/non-examples/stack-traces/in-arg-error.golden @@ -0,0 +1 @@ +Type mismatch at in-arg-error.kl:5.23-5.38. Expected Syntax but got String diff --git a/examples/non-examples/stack-traces/in-arg-error.kl b/examples/non-examples/stack-traces/in-arg-error.kl new file mode 100644 index 00000000..2494e15a --- /dev/null +++ b/examples/non-examples/stack-traces/in-arg-error.kl @@ -0,0 +1,5 @@ +#lang "prelude.kl" + +(define fail (lambda (something) (+ something 1))) + +(example (fail (error "in-arg-error!"))) diff --git a/examples/prelude-test.golden b/examples/prelude-test.golden index e4458dc3..472b0675 100644 --- a/examples/prelude-test.golden +++ b/examples/prelude-test.golden @@ -1,4 +1,4 @@ #[prelude-test.kl:3.18-3.19] : Syntax -# : ∀(α : *) (β : *). ((α → β) → (α → β)) -# : ∀(α : *). (α → α) -# : ∀(α : *). (α → α) +# : ∀(α : *) (β : *). ((α → β) → (α → β)) +# : ∀(α : *). (α → α) +# : ∀(α : *). (α → α) diff --git a/examples/primitives-documentation.golden b/examples/primitives-documentation.golden index f92ed433..c7d13f37 100644 --- a/examples/primitives-documentation.golden +++ b/examples/primitives-documentation.golden @@ -1,33 +1,33 @@ -(pair "open-syntax" #) : (Pair String (Syntax → (Syntax-Contents Syntax))) -(pair "close-syntax" #) : (Pair String (Syntax → (Syntax → ((Syntax-Contents Syntax) → Syntax)))) -(pair "+" #) : (Pair String (Integer → (Integer → Integer))) -(pair "-" #) : (Pair String (Integer → (Integer → Integer))) -(pair "*" #) : (Pair String (Integer → (Integer → Integer))) -(pair "/" #) : (Pair String (Integer → (Integer → Integer))) -(pair "abs" #) : (Pair String (Integer → Integer)) -(pair "negate" #) : (Pair String (Integer → Integer)) -(pair ">" #) : (Pair String (Integer → (Integer → Bool))) -(pair ">=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "<" #) : (Pair String (Integer → (Integer → Bool))) -(pair "<=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "/=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "integer->string" #) : (Pair String (Integer → String)) -(pair "string-append" #) : (Pair String (String → (String → String))) -(pair "substring" #) : (Pair String (Integer → (Integer → (String → (Maybe String))))) -(pair "string-length" #) : (Pair String (String → Integer)) -(pair "string=?" #) : (Pair String (String → (String → Bool))) -(pair "string/=?" #) : (Pair String (String → (String → Bool))) -(pair "string) : (Pair String (String → (String → Bool))) -(pair "string<=?" #) : (Pair String (String → (String → Bool))) -(pair "string>?" #) : (Pair String (String → (String → Bool))) -(pair "string>=?" #) : (Pair String (String → (String → Bool))) -(pair "string-upcase" #) : (Pair String (String → String)) -(pair "string-downcase" #) : (Pair String (String → String)) -(pair "string-titlecase" #) : (Pair String (String → String)) -(pair "string-foldcase" #) : (Pair String (String → String)) -(pair "pure-IO" #) : ∀(α : *). (Pair String (α → (IO α))) -(pair "bind-IO" #) : ∀(α : *) (β : *). (Pair String ((IO α) → ((α → (IO β)) → (IO β)))) +(pair "open-syntax" #) : (Pair String (Syntax → (Syntax-Contents Syntax))) +(pair "close-syntax" #) : (Pair String (Syntax → (Syntax → ((Syntax-Contents Syntax) → Syntax)))) +(pair "+" #) : (Pair String (Integer → (Integer → Integer))) +(pair "-" #) : (Pair String (Integer → (Integer → Integer))) +(pair "*" #) : (Pair String (Integer → (Integer → Integer))) +(pair "/" #) : (Pair String (Integer → (Integer → Integer))) +(pair "abs" #) : (Pair String (Integer → Integer)) +(pair "negate" #) : (Pair String (Integer → Integer)) +(pair ">" #) : (Pair String (Integer → (Integer → Bool))) +(pair ">=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "<" #) : (Pair String (Integer → (Integer → Bool))) +(pair "<=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "/=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "integer->string" #string>) : (Pair String (Integer → String)) +(pair "string-append" #) : (Pair String (String → (String → String))) +(pair "substring" #) : (Pair String (Integer → (Integer → (String → (Maybe String))))) +(pair "string-length" #) : (Pair String (String → Integer)) +(pair "string=?" #) : (Pair String (String → (String → Bool))) +(pair "string/=?" #) : (Pair String (String → (String → Bool))) +(pair "string) : (Pair String (String → (String → Bool))) +(pair "string<=?" #) : (Pair String (String → (String → Bool))) +(pair "string>?" #) : (Pair String (String → (String → Bool))) +(pair "string>=?" #) : (Pair String (String → (String → Bool))) +(pair "string-upcase" #) : (Pair String (String → String)) +(pair "string-downcase" #) : (Pair String (String → String)) +(pair "string-titlecase" #) : (Pair String (String → String)) +(pair "string-foldcase" #) : (Pair String (String → String)) +(pair "pure-IO" #) : ∀(α : *). (Pair String (α → (IO α))) +(pair "bind-IO" #) : ∀(α : *) (β : *). (Pair String ((IO α) → ((α → (IO β)) → (IO β)))) (flip) : ScopeAction (add) : ScopeAction (remove) : ScopeAction @@ -43,8 +43,8 @@ (nil) : ∀(α : *). (List α) make-introducer : (Macro (ScopeAction → (Syntax → Syntax))) which-problem : (Macro Problem) -(pair "id" #) : ∀(α : *). (Pair String (α → α)) -(pair "const" #) : ∀(α : *) (β : *). (Pair String (α → (β → α))) -(pair "compose" #) : ∀(α : *) (β : *) (γ : *). (Pair String ((α → β) → ((γ → α) → (γ → β)))) +(pair "id" #) : ∀(α : *). (Pair String (α → α)) +(pair "const" #) : ∀(α : *) (β : *). (Pair String (α → (β → α))) +(pair "compose" #) : ∀(α : *) (β : *) (γ : *). (Pair String ((α → β) → ((γ → α) → (γ → β)))) (pair "stdout" #) : (Pair String Output-Port) -(pair "write" #) : (Pair String (Output-Port → (String → (IO Unit)))) +(pair "write" #) : (Pair String (Output-Port → (String → (IO Unit)))) diff --git a/examples/product-type.golden b/examples/product-type.golden index cfa22906..fdd2b206 100644 --- a/examples/product-type.golden +++ b/examples/product-type.golden @@ -1,2 +1,2 @@ #[product-type.kl:12.23-12.24] : Syntax -# : ∀(α : *) (β : *). ((× α β) → α) +# : ∀(α : *) (β : *). ((× α β) → α) diff --git a/examples/tiny-types.golden b/examples/tiny-types.golden index 7d082367..3b69342d 100644 --- a/examples/tiny-types.golden +++ b/examples/tiny-types.golden @@ -2,10 +2,10 @@ (false) : Bool #[tiny-types.kl:5.25-5.28] : Syntax pure #[tiny-types.kl:6.39-6.42] : (Macro Syntax) -# : (Bool → Bool) -# : (Bool → Syntax) +# : (Bool → Bool) +# : (Bool → Syntax) (free-identifier=? #[tiny-types.kl:10.40-10.41] #[tiny-types.kl:10.43-10.44]) >>= -# : (Macro (Bool → Bool)) +# : (Macro (Bool → Bool)) diff --git a/examples/unknown-type.golden b/examples/unknown-type.golden index 3f4b291b..bdfca69b 100644 --- a/examples/unknown-type.golden +++ b/examples/unknown-type.golden @@ -1,4 +1,4 @@ (nothing) : ∀(α : *). (Maybe α) (just #[unknown-type.kl:24.33-24.37]) : (Maybe Syntax) -(just #) : ∀(α : *). (Maybe (α → α)) -(pair (just #) (nothing)) : ∀(α : *). (Pair (Maybe (α → α)) (Maybe (α → α))) +(just #) : ∀(α : *). (Maybe (α → α)) +(pair (just #) (nothing)) : ∀(α : *). (Pair (Maybe (α → α)) (Maybe (α → α))) diff --git a/examples/which-problem.golden b/examples/which-problem.golden index 558d37f4..d5fa3651 100644 --- a/examples/which-problem.golden +++ b/examples/which-problem.golden @@ -1,9 +1,9 @@ (true) : Bool (true) : Bool -# : (Bool → (Bool → (Bool → (Bool → Unit)))) -# : (Bool → (Bool → (Bool → (Bool → Unit)))) -(both # #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) -(both # #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) +#<_> : (Bool → (Bool → (Bool → (Bool → Unit)))) +#<_> : (Bool → (Bool → (Bool → (Bool → Unit)))) +(both # #<_>) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) +(both #<_> #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) "String" : String "String -> String" : String "String -> String -> String" : String diff --git a/flake.nix b/flake.nix index d14f0e09..4e90c211 100644 --- a/flake.nix +++ b/flake.nix @@ -21,7 +21,7 @@ hPkgs.haskell-language-server # LSP server for editor hPkgs.implicit-hie # auto generate LSP hie.yaml file from cabal hPkgs.retrie # Haskell refactoring tool - # hPkgs.cabal-install + hPkgs.cabal-install stack-wrapped pkgs.zlib # External C library needed by some Haskell packages ]; @@ -52,6 +52,9 @@ # pkgs.haskell.lib.buildStackProject does # https://github.com/NixOS/nixpkgs/blob/d64780ea0e22b5f61cd6012a456869c702a72f20/pkgs/development/haskell-modules/generic-stack-builder.nix#L38 LD_LIBRARY_PATH = pkgs.lib.makeLibraryPath myDevTools; + shellHook = '' + export KLISTERPATH="$(pwd)"/examples/ + ''; }; }); } diff --git a/klister.cabal b/klister.cabal index 323f6de6..1850db38 100644 --- a/klister.cabal +++ b/klister.cabal @@ -59,6 +59,7 @@ library Control.Lens.IORef Core Core.Builder + Debugger Datatype Env Evaluator diff --git a/repl/Main.hs b/repl/Main.hs index 319a0309..c2557856 100644 --- a/repl/Main.hs +++ b/repl/Main.hs @@ -33,12 +33,12 @@ import Syntax import Value import World -data Options = Options { optCommand :: CLICommand } -data RunOptions = RunOptions { runOptFile :: FilePath - , runOptWorld :: Bool +newtype Options = Options { optCommand :: CLICommand } +data RunOptions = RunOptions { runOptFile :: FilePath + , runOptWorld :: Bool , runOptBindingInfo :: Bool } -data ReplOptions = ReplOptions { replOptFile :: Maybe FilePath } +newtype ReplOptions = ReplOptions { replOptFile :: Maybe FilePath } data CLICommand = Run RunOptions @@ -63,8 +63,8 @@ main = do replOptions = Repl . ReplOptions <$> optional fileArg parser = Options <$> subparser - ( (command "run" (info runOptions (progDesc "Run a file"))) - <> (command "repl" (info replOptions (progDesc "Use the REPL"))) + ( command "run" (info runOptions (progDesc "Run a file")) + <> command "repl" (info replOptions (progDesc "Use the REPL")) ) opts = info parser mempty @@ -147,5 +147,5 @@ repl ctx startWorld = do putStrLn "" currentWorld <- readIORef theWorld case evaluateIn (phaseEnv runtime currentWorld) expr of - Left evalErr -> print $ erroneousValue $ projectError evalErr + Left evalErr -> print evalErr Right val -> prettyPrintLn val diff --git a/src/Debugger.hs b/src/Debugger.hs new file mode 100644 index 00000000..8b70f489 --- /dev/null +++ b/src/Debugger.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Debugger +-- Copyright : (c) Jeffrey M. Young +-- Samuel Gélineau +-- David Thrane Christiansen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Samuel Gélineau +-- David Christiansen +-- Stability : experimental +-- +-- A Common Lisp style Debugger for klister. +----------------------------------------------------------------------------- + + +module Debugger where + -- DYG explicit export list + +import Evaluator + +import Data.Bifunctor +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.State.Lazy as LazyState +import qualified Control.Monad.Trans.State.Strict as StrictState +import qualified Control.Monad.Trans.Reader as Reader +-- ----------------------------------------------------------------------------- +-- Types + + +-- conceptually this is a ReaderT (DebugContext e) (ExceptT e) IO a but I've +-- just fused the transformers to have more control over the monad instance +newtype Debug r e a = Debug { runDebug :: r -> IO (Either e a) + } + +debugRunT :: r -> Debug r e a -> IO (Either e a) +debugRunT = flip runDebug + +{-# INLINE mapDebugT #-} +mapDebugT :: (a -> b) -> Debug r e a -> Debug r e b +mapDebugT f = Debug . fmap (fmap (second f)) . runDebug + +withDebug :: (r' -> r) -> Debug r e a -> Debug r' e a +withDebug f m = Debug $ runDebug m . f + +ask' :: Debug r e r +ask' = Debug $ \r -> return $ Right r + +instance Functor (Debug r e) where + fmap = mapDebugT + +instance Applicative (Debug r e) where + pure a = Debug $ const (return (Right a)) + Debug f <*> Debug v = Debug $ \rr -> do + mf <- f rr + case mf of + (Left fer) -> return (Left fer) + (Right k) -> do + mv <- v rr + case mv of + (Left ver) -> return (Left ver) + Right x -> return (Right (k x)) + +instance Monad (Debug r e) where + Debug m >>= f = Debug $ \r -> do + ma <- m r + case ma of + Left err -> return (Left err) + Right val -> fmap (debugRunT r) f val + +instance MonadIO (Debug r e) where + liftIO = Debug . const . fmap Right + +instance MonadDebugger e m => MonadDebugger e (ReaderT r m) where + debug = lift . debug + catch = Reader.liftCatch catch + +instance MonadDebugger e m => MonadDebugger e (LazyState.StateT s m) where + debug = lift . debug + catch = LazyState.liftCatch catch + +instance MonadDebugger e m => MonadDebugger e (StrictState.StateT s m) where + debug = lift . debug + catch = StrictState.liftCatch catch + +-- | Type class that defines the interface for any debugger. Each instance is a +-- debugger in their own right +class (Monad io, MonadIO io) => MonadDebugger e io | io -> e where + -- conceptually this is throw + debug :: e -> io a + -- conceptually this is catch with a handler + catch :: io a -> (e -> io a) -> io a + +-- | This debugger is the simplest debugger. It accepts no user inputs, instead +-- it only reports whatever stack trace its recorded. +instance MonadDebugger e (Debug DebugContext e) where + debug e = Debug $ const (return (Left e)) + catch (Debug m) hndl = Debug $ \r -> do + a <- m r + case a of + Left e -> runDebug (hndl e) r + v@Right{} -> return v + +data DebugContext = DebugContext { _stackTrace :: [EState] + } + deriving Show + +initialContext :: DebugContext +initialContext = DebugContext mempty + + +-- checkError :: Debug e (Maybe e) +-- checkError = R.asks _currentError + +-- DYG next: +-- - instead of projecting the error in debug invocations (see line 870 in Expander.Monad) +-- - we record the stack trace +-- - also merge catch and debug. In the debugger as envisioned these are the same things +-- - can we write a combinator that wraps a computation with a standard handler? +-- - I definitely believe we can, there are likely classes of handlers, with the simplest +-- - one being throwError that just reports the error. + +-- ----------------------------------------------------------------------------- +-- Top level API + +-- enterDebugger :: ExpansionErr -> EState -> Debug Value +-- enterDebugger exp_err st = diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 0766190d..e9b333c7 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -8,10 +8,27 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : CEK Machine +-- Copyright : (c) Jeffrey M. Young +-- Samuel Gélineau +-- David Thrane Christiansen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Samuel Gélineau +-- David Christiansen +-- Stability : experimental +-- +-- Converting state from the CEK machine to stack trace +----------------------------------------------------------------------------- + + {- Note [The CEK interpreter]: -The Klister interpreter is a straightforward implementation of a CEK -interpreter. The interpreter keeps three kinds of state: +The Klister interpreter is a straightforward implementation of a CEK machine. +The interpreter keeps three kinds of state: -- C: Control ::= The thing that is being evaluated -- E: Environment ::= The interpreter environment @@ -29,7 +46,7 @@ https://felleisen.org/matthias/4400-s20/lecture23.html The bird's eye view: -The evaluator crawl's the input AST and progresses in three modes: +The evaluator crawls the input AST and progresses in three modes: -- 'Down': meaning that the evaluator is searching for a redex to evaluate and -- therefore moving "down" the AST. @@ -50,18 +67,23 @@ allows the evaluator to know exactly what needs to happen in order to continue. module Evaluator ( EvalError (..) , EvalResult (..) + , EState (..) + , Kont (..) + , VEnv , TypeError (..) , evaluate , evaluateIn , evaluateWithExtendedEnv , evalErrorType , evalErrorText - , projectError , erroneousValue , applyInEnv , apply , doTypeCase , try + , projectError + , projectKont + , constructErrorType ) where import Control.Lens hiding (List, elements) @@ -96,7 +118,6 @@ data TypeError = TypeError , _typeErrorActual :: Type } deriving (Eq, Show) -makeLenses ''TypeError data EvalError = EvalErrorUnbound Var @@ -136,6 +157,15 @@ data Kont where InDataCaseScrut :: ![(ConstructorPattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont InTypeCaseScrut :: ![(TypePattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont + {- Note [InCasePattern] + In case pattern is strictly not necessary, we could do this evaluation in + the host's runtime instead of in the evaluator but doing so would mean that + the debugger would not be able to capture the pattern that was matched. + -} + InPrim :: !Text -> !Kont -> Kont + InCasePattern :: !SyntaxPattern -> !Kont -> Kont + InDataCasePattern :: !ConstructorPattern -> !Kont -> Kont + -- lists InConsHd :: !Core -> !(CoreF TypePattern ConstructorPattern Core) -> !VEnv -> !Kont -> Kont InConsTl :: !Core -> !Syntax -> !VEnv -> !Kont -> Kont @@ -164,9 +194,9 @@ data Kont where InLog :: !VEnv -> !Kont -> Kont InError :: !VEnv -> !Kont -> Kont - InSyntaxErrorMessage :: ![Core] -> !VEnv -> !Kont -> Kont InSyntaxErrorLocations :: !Syntax -> ![Core] -> ![Syntax] -> !VEnv -> !Kont -> Kont + deriving Show -- | The state of the evaluator data EState where @@ -178,7 +208,7 @@ data EState where -- returning a value up the stack Er :: !EvalError -> !VEnv -> !Kont -> EState -- ^ 'Er', meaning that we are in an error state and running the debugger - + deriving Show -- ----------------------------------------------------------------------------- -- The evaluator. The CEK machine is a state machine, the @step@ function moves @@ -222,6 +252,10 @@ step (Up v e k) = (\good -> Up (ValueMacroAction $ MacroActionTypeCase e loc good cs) env kont) (\err -> Er err env kont) + -- Case passthroughs, see the Note [InCasePattern] + (InPrim _ kont) -> Up v e kont + (InCasePattern _ kont) -> Up v e kont + (InDataCasePattern _ kont) -> Up v e kont -- Idents (InIdent scope env kont) -> case v of @@ -493,13 +527,13 @@ evalAsType v on_success on_error = other -> on_error (evalErrorType "type" other) applyInEnv :: VEnv -> Closure -> Value -> Either EState Value -applyInEnv old_env (FO (FOClosure {..})) value = +applyInEnv _old_env (FO (FOClosure {..})) value = let env = Env.insert _closureVar _closureIdent value - (_closureEnv <> old_env) + (_closureEnv) in evaluateIn env _closureBody -applyInEnv _ (HO prim) value = return $! prim value +applyInEnv _ (HO _n prim) value = return $! prim value apply :: Closure -> Value -> Either EState Value apply (FO (FOClosure {..})) value = @@ -508,7 +542,7 @@ apply (FO (FOClosure {..})) value = value _closureEnv in evaluateIn env _closureBody -apply (HO prim) value = return $! prim value +apply (HO _n prim) value = return $! prim value applyAsClosure :: VEnv -> Value -> Value -> Kont -> EState applyAsClosure e v_closure value k = case v_closure of @@ -518,7 +552,7 @@ applyAsClosure e v_closure value k = case v_closure of where app (FO (FOClosure{..})) = let env = Env.insert _closureVar _closureIdent value (_closureEnv <> e) in Down (unCore _closureBody) env k - app (HO prim) = Up (prim value) mempty k + app (HO n prim) = Up (prim value) mempty (InPrim n k) -- | predicate to check for done state final :: EState -> Bool @@ -544,9 +578,21 @@ extends exts env = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env exts evalErrorType :: Text -> Value -> EvalError evalErrorType expected got = EvalErrorType $ TypeError - { _typeErrorExpected = expected - , _typeErrorActual = describeVal got - } + { _typeErrorExpected = expected + , _typeErrorActual = describeVal got + } + +-- this is a copy of 'evalErrorType' but with no memory of how we got to this +-- error state. This should just be a stopgap and we should remove it. Its sole +-- use case is in the expander where we have redundant error checks due to +-- functions such as @doTypeCase@ +constructErrorType :: Text -> Value -> EState +constructErrorType expected got = Er err mempty Halt + where + err = EvalErrorType $ TypeError + { _typeErrorExpected = expected + , _typeErrorActual = describeVal got + } doTypeCase :: VEnv -> SrcLoc -> Ty -> [(TypePattern, Core)] -> Either EState Value -- We pass @Right $ ValueType v0@ here so that the Core type-case still matches @@ -582,34 +628,34 @@ doCase :: SrcLoc -> Value -> [(SyntaxPattern, Core)] -> VEnv -> Kont -> EState doCase blameLoc v0 [] e kont = Er (EvalErrorCase blameLoc v0) e kont doCase blameLoc v0 ((p, rhs0) : ps) e kont = match (doCase blameLoc v0 ps e kont) p rhs0 v0 e kont where - match next (SyntaxPatternIdentifier n x) rhs scrutinee env k = + match next pat@(SyntaxPatternIdentifier n x) rhs scrutinee env k = case scrutinee of v@(ValueSyntax (Syntax (Stx _ _ (Id _)))) -> - step $ Down (unCore rhs) (extend n x v env) k + step $ Down (unCore rhs) (extend n x v env) (InCasePattern pat k) _ -> next - match next (SyntaxPatternInteger n x) rhs scrutinee env k = + match next pat@(SyntaxPatternInteger n x) rhs scrutinee env k = case scrutinee of ValueSyntax (Syntax (Stx _ _ (Integer int))) -> - step $ Down (unCore rhs) (extend n x (ValueInteger int) env) k + step $ Down (unCore rhs) (extend n x (ValueInteger int) env) (InCasePattern pat k) _ -> next - match next (SyntaxPatternString n x) rhs scrutinee env k = + match next pat@(SyntaxPatternString n x) rhs scrutinee env k = case scrutinee of ValueSyntax (Syntax (Stx _ _ (String str))) -> - step $ Down (unCore rhs) (extend n x (ValueString str) env) k + step $ Down (unCore rhs) (extend n x (ValueString str) env) (InCasePattern pat k) _ -> next match next SyntaxPatternEmpty rhs scrutinee env k = case scrutinee of (ValueSyntax (Syntax (Stx _ _ (List [])))) -> - step $ Down (unCore rhs) env k + step $ Down (unCore rhs) env (InCasePattern SyntaxPatternEmpty k) _ -> next - match next (SyntaxPatternCons nx x nxs xs) rhs scrutinee env k = + match next pat@(SyntaxPatternCons nx x nxs xs) rhs scrutinee env k = case scrutinee of (ValueSyntax (Syntax (Stx scs loc (List (v:vs))))) -> let mkEnv = extend nx x (ValueSyntax v) . extend nxs xs (ValueSyntax (Syntax (Stx scs loc (List vs)))) - in step $ Down (unCore rhs) (mkEnv env) k + in step $ Down (unCore rhs) (mkEnv env) (InCasePattern pat k) _ -> next - match next (SyntaxPatternList xs) rhs scrutinee env k = + match next pat@(SyntaxPatternList xs) rhs scrutinee env k = case scrutinee of (ValueSyntax (Syntax (Stx _ _ (List vs)))) | length vs == length xs -> @@ -617,15 +663,15 @@ doCase blameLoc v0 ((p, rhs0) : ps) e kont = match (doCase blameLoc v0 ps e kon | (n,x) <- xs | v <- vs ] - in step $ Down (unCore rhs) (vals `extends` env) k + in step $ Down (unCore rhs) (vals `extends` env) (InCasePattern pat k) _ -> next match _next SyntaxPatternAny rhs _scrutinee env k = - step $ Down (unCore rhs) env k + step $ Down (unCore rhs) env (InCasePattern SyntaxPatternAny k) doDataCase :: SrcLoc -> Value -> [(ConstructorPattern, Core)] -> VEnv -> Kont -> EState doDataCase loc v0 [] env kont = Er (EvalErrorCase loc v0) env kont doDataCase loc v0 ((pat, rhs) : ps) env kont = - match (doDataCase loc v0 ps env kont) (\newEnv -> step $ Down (unCore rhs) newEnv kont) [(unConstructorPattern pat, v0)] + match (doDataCase loc v0 ps env kont) (\newEnv -> step $ Down (unCore rhs) newEnv (InDataCasePattern pat kont)) [(unConstructorPattern pat, v0)] where match :: EState {- ^ Failure continuation -} @@ -658,11 +704,6 @@ evaluateWithExtendedEnv env exts = evaluateIn (inserter exts) where inserter = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env --- TODO DYG: Move to separate module -projectError :: EState -> EvalError -projectError (Er err _env _k) = err -projectError _ = error "debugger: impossible" - erroneousValue :: EvalError -> Value erroneousValue (EvalErrorCase _loc v) = v erroneousValue (EvalErrorIdent v) = v @@ -670,3 +711,12 @@ erroneousValue _ = error $ mconcat [ "erroneousValue: " , "Evaluator concluded in an error that did not return a value" ] + +projectError :: EState -> EvalError +projectError (Er err _env _kont) = err +projectError _ = error "projectError not used on an error!" + +projectKont :: EState -> Kont +projectKont (Er _ _ k) = k +projectKont (Up _ _ k) = k +projectKont (Down _ _ k) = k diff --git a/src/Expander.hs b/src/Expander.hs index 6854f5b8..e4ce3cb1 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -38,7 +38,6 @@ import Control.Applicative import Control.Lens hiding (List, children) import Control.Monad import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Except (MonadError(catchError, throwError)) import Control.Monad.Reader (MonadReader(local)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad.Trans.State.Strict (StateT, execStateT, modify', runStateT) @@ -59,6 +58,7 @@ import System.IO (Handle) import Binding import Core import Datatype +import Debugger import qualified Env import Evaluator import qualified Expander.Primitives as Prims @@ -150,10 +150,10 @@ loadModuleFile modName = return (KernelModule p, es) Left file -> do existsp <- liftIO $ doesFileExist file - when (not existsp) $ throwError $ NoSuchFile $ show file + when (not existsp) $ debug $ NoSuchFile $ show file stx <- liftIO (readModule file) >>= \case - Left err -> throwError $ ReaderError err + Left err -> debug $ ReaderError err Right stx -> return stx startExports <- view expanderModuleExports <$> getState modifyState $ set expanderModuleExports noExports @@ -196,7 +196,7 @@ getImports (ImportOnly spec idents) = do -- Check that all the identifiers are actually exported for_ idents $ \x -> case getExport p (view stxValue x) imports of - Nothing -> throwError $ NotExported x p + Nothing -> debug $ NotExported x p Just _ -> pure () return $ filterExports (\_ x -> x `elem` (map (view stxValue) idents)) imports getImports (ShiftImports spec i) = do @@ -306,7 +306,7 @@ evalMod (Expanded em _) = execStateT (traverseOf_ (moduleBody . each) evalDecl e \case (ValueIOAction act) -> modify' (:|> (IOResult . void $ act)) - _ -> throwError $ InternalError $ + _ -> debug $ InternalError $ "While running an action at " ++ T.unpack (pretty loc) ++ " an unexpected non-IO value was encountered." @@ -331,7 +331,7 @@ getEValue b = do ExpansionEnv env <- view expanderExpansionEnv <$> getState case S.lookup b env of Just v -> return v - Nothing -> throwError (InternalError ("No such binding: " ++ show b)) + Nothing -> debug (InternalError ("No such binding: " ++ show b)) visibleBindings :: Expand BindingTable @@ -357,7 +357,7 @@ checkUnambiguous best candidates blame = let bestSize = ScopeSet.size p best let candidateSizes = map (ScopeSet.size p) (nub $ toList candidates) if length (filter (== bestSize) candidateSizes) > 1 - then throwError (Ambiguous p blame candidates) + then debug (Ambiguous p blame candidates) else return () resolve :: Ident -> Expand Binding @@ -366,7 +366,8 @@ resolve stx@(Stx scs srcLoc x) = do bs <- allMatchingBindings x scs case bs of Seq.Empty -> - throwError (Unknown (Stx scs srcLoc x)) + do + debug (Unknown (Stx scs srcLoc x)) candidates -> let check = ScopeSet.size p . fst @@ -404,7 +405,7 @@ initializeKernel outputChannel = do funPrims = [ ( "open-syntax" , Scheme [] $ tFun [tSyntax] (Prims.primitiveDatatype "Syntax-Contents" [tSyntax]) - , ValueClosure $ HO $ + , ValueClosure $ HO "open-syntax" $ \(ValueSyntax stx) -> case syntaxE stx of Id name -> @@ -422,11 +423,11 @@ initializeKernel outputChannel = do , ( "close-syntax" , Scheme [] $ tFun [tSyntax, tSyntax, Prims.primitiveDatatype "Syntax-Contents" [tSyntax]] tSyntax - , ValueClosure $ HO $ + , ValueClosure $ HO "close-syntax" $ \(ValueSyntax locStx) -> - ValueClosure $ HO $ + ValueClosure $ HO "close-syntax2" $ \(ValueSyntax scopesStx) -> - ValueClosure $ HO $ + ValueClosure $ HO "close-syntax3" $ -- N.B. Assuming correct constructors \(ValueCtor ctor [arg]) -> let close x = Syntax $ Stx (view (unSyntax . stxScopeSet) scopesStx) (stxLoc locStx) x @@ -456,9 +457,9 @@ initializeKernel outputChannel = do ] ++ [ ( "string=?" , Scheme [] $ tFun [tString, tString] (Prims.primitiveDatatype "Bool" []) - , ValueClosure $ HO $ + , ValueClosure $ HO "string=? operator" $ \(ValueString str1) -> - ValueClosure $ HO $ + ValueClosure $ HO "string=? operand" $ \(ValueString str2) -> if str1 == str2 then primitiveCtor "true" [] @@ -466,26 +467,26 @@ initializeKernel outputChannel = do ) , ( "string-append" , Scheme [] $ tFun [tString, tString] tString - , ValueClosure $ HO $ + , ValueClosure $ HO "string-append-l" $ \(ValueString str1) -> - ValueClosure $ HO $ + ValueClosure $ HO "string-append-r" $ \(ValueString str2) -> ValueString (str1 <> str2) ) , ( "integer->string" , Scheme [] $ tFun [tInteger] tString - , ValueClosure $ HO $ + , ValueClosure $ HO "integer->string" $ \(ValueInteger int) -> ValueString (T.pack (show int)) ) , ( "substring" , Scheme [] $ tFun [tInteger, tInteger, tString] (Prims.primitiveDatatype "Maybe" [tString]) - , ValueClosure $ HO $ + , ValueClosure $ HO "substing" $ \(ValueInteger (fromInteger -> start)) -> - ValueClosure $ HO $ + ValueClosure $ HO "substring2" $ \(ValueInteger (fromInteger -> len)) -> - ValueClosure $ HO $ + ValueClosure $ HO "substring3" $ \(ValueString str) -> if | start < 0 || start >= T.length str -> primitiveCtor "nothing" [] | len < 0 || start + len > T.length str -> primitiveCtor "nothing" [] @@ -494,23 +495,23 @@ initializeKernel outputChannel = do ) , ( "string-length" , Scheme [] $ tFun [tString] tInteger - , ValueClosure $ HO $ \(ValueString str) -> ValueInteger $ toInteger $ T.length str + , ValueClosure $ HO "string-length" $ \(ValueString str) -> ValueInteger $ toInteger $ T.length str ) , ( "string-downcase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toLower str + , ValueClosure $ HO "string-downcase" $ \(ValueString str) -> ValueString $ T.toLower str ) , ( "string-upcase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toUpper str + , ValueClosure $ HO "string-upcase" $ \(ValueString str) -> ValueString $ T.toUpper str ) , ( "string-titlecase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toTitle str + , ValueClosure $ HO "string-titlecase" $ \(ValueString str) -> ValueString $ T.toTitle str ) , ( "string-foldcase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toCaseFold str + , ValueClosure $ HO "string-foldcase" $ \(ValueString str) -> ValueString $ T.toCaseFold str ) ] ++ [ ( "string" <> name <> "?" @@ -540,7 +541,7 @@ initializeKernel outputChannel = do ] ++ [ ("pure-IO" , Scheme [KStar, KStar] $ tFun [tSchemaVar 0 []] (tIO (tSchemaVar 0 [])) - , ValueClosure $ HO $ \v -> ValueIOAction (pure v) + , ValueClosure $ HO "pure-IO" $ \v -> ValueIOAction (pure v) ) , ("bind-IO" , Scheme [KStar, KStar] $ @@ -548,19 +549,19 @@ initializeKernel outputChannel = do , tFun [tSchemaVar 0 []] (tIO (tSchemaVar 1 [])) ] (tIO (tSchemaVar 1 [])) - , ValueClosure $ HO $ \(ValueIOAction mx) -> do - ValueClosure $ HO $ \(ValueClosure f) -> do + , ValueClosure $ HO "action" $ \(ValueIOAction mx) -> do + ValueClosure $ HO "closure" $ \(ValueClosure f) -> do ValueIOAction $ do vx <- mx vioy <- case f of - HO fun -> pure (fun vx) + HO _str fun -> pure (fun vx) FO clos -> do let env = view closureEnv clos var = view closureVar clos ident = view closureIdent clos body = view closureBody clos case (evaluateWithExtendedEnv env [(ident, var, vx)] body) of - Left err -> error (T.unpack (pretty $ projectError err)) + Left err -> error (T.unpack (pretty err)) Right vioy -> pure vioy let ValueIOAction my = vioy my @@ -571,9 +572,9 @@ initializeKernel outputChannel = do ) , ( "write" , Scheme [] $ tFun [tOutputPort, tString] (tIO (Prims.primitiveDatatype "Unit" [])) - , ValueClosure $ HO $ + , ValueClosure $ HO "write" $ \(ValueOutputPort h) -> - ValueClosure $ HO $ + ValueClosure $ HO "write" $ \(ValueString str) -> ValueIOAction $ do T.hPutStr h str @@ -789,7 +790,7 @@ primImportModule dest outScopesDest importStx = do subSpec <- importSpec spec Stx _ _ p <- mustBeIdent prefix return $ PrefixImports subSpec p - | otherwise = throwError $ NotImportSpec stx + | otherwise = debug $ NotImportSpec stx importSpec modStx = ImportModule <$> mustBeModName modStx getRename s = do Stx _ _ (old', new') <- mustHaveEntries s @@ -816,24 +817,24 @@ primExport dest outScopesDest stx = do pairs <- getRenames blame rens spec <- exportSpec blame more return $ ExportRenamed spec pairs - _ -> throwError $ NotExportSpec blame + _ -> debug $ NotExportSpec blame "prefix" -> case args of ((syntaxE -> String pref) : more) -> do spec <- exportSpec blame more return $ ExportPrefixed spec pref - _ -> throwError $ NotExportSpec blame + _ -> debug $ NotExportSpec blame "shift" -> case args of (Syntax (Stx _ _ (Integer i)) : more) -> do spec <- exportSpec (Syntax (Stx scs' srcloc' (List more))) more if i >= 0 then return $ ExportShifted spec (fromIntegral i) - else throwError $ NotExportSpec blame - _ -> throwError $ NotExportSpec blame - _ -> throwError $ NotExportSpec blame + else debug $ NotExportSpec blame + _ -> debug $ NotExportSpec blame + _ -> debug $ NotExportSpec blame | Just xs <- traverse getIdent elts = return (ExportIdents xs) - | otherwise = throwError $ NotExportSpec blame + | otherwise = debug $ NotExportSpec blame getIdent (Syntax (Stx scs loc (Id x))) = pure (Stx scs loc x) @@ -845,7 +846,7 @@ primExport dest outScopesDest stx = do Stx _ _ x' <- mustBeIdent x Stx _ _ y' <- mustBeIdent y pure (x', y') - getRenames blame _ = throwError $ NotExportSpec blame + getRenames blame _ = debug $ NotExportSpec blame identifierHeaded :: Syntax -> Maybe Ident identifierHeaded (Syntax (Stx scs srcloc (Id x))) = Just (Stx scs srcloc x) @@ -911,13 +912,11 @@ runTask (tid, localData, task) = withLocal localData $ do forkInterpretMacroAction dest nextStep kont otherVal -> do p <- currentPhase - throwError $ MacroEvaluationError p $ evalErrorType "macro action" otherVal + debug $ MacroEvaluationError p $ constructErrorType "macro action" otherVal Left err -> do -- an error occurred in the evaluator, so just report it p <- currentPhase - throwError - $ MacroEvaluationError p - $ projectError err + debug $ MacroEvaluationError p err AwaitingMacro dest (TaskAwaitMacro b v x deps mdest stx) -> do newDeps <- concat <$> traverse dependencies deps case newDeps of @@ -982,23 +981,19 @@ runTask (tid, localData, task) = withLocal localData $ do forkExpandSyntax dest syntax other -> do p <- currentPhase - throwError $ MacroEvaluationError p $ evalErrorType "syntax" other + debug $ MacroEvaluationError p $ constructErrorType "syntax" other ContinueMacroAction dest value (closure:kont) -> do case apply closure value of Left err -> do p <- currentPhase - throwError - $ MacroEvaluationError p - $ evalErrorType "macro action" - $ erroneousValue - $ projectError err + debug $ MacroEvaluationError p err Right v -> case v of ValueMacroAction macroAction -> do forkInterpretMacroAction dest macroAction kont other -> do p <- currentPhase - throwError $ MacroEvaluationError p $ evalErrorType "macro action" other + debug $ MacroEvaluationError p $ constructErrorType "macro action" other EvalDefnAction x n p expr -> linkedCore expr >>= \case @@ -1016,7 +1011,7 @@ runTask (tid, localData, task) = withLocal localData $ do then do st <- getState case view (expanderExpressionTypes . at edest) st of - Nothing -> throwError $ InternalError "Type not found during generalization" + Nothing -> debug $ InternalError "Type not found during generalization" Just _ -> do sch <- generalizeType ty linkScheme schdest sch @@ -1056,7 +1051,7 @@ runTask (tid, localData, task) = withLocal localData $ do (view (expanderPatternBinders . at ptr) <$> getState) >>= \case Nothing -> - throwError $ InternalError "Pattern info not added" + debug $ InternalError "Pattern info not added" Just (Right found) -> pure [found] Just (Left ptrs) -> @@ -1079,7 +1074,7 @@ runTask (tid, localData, task) = withLocal localData $ do else do varInfo <- view (expanderTypePatternBinders . at patPtr) <$> getState case varInfo of - Nothing -> throwError $ InternalError "Type pattern info not added" + Nothing -> debug $ InternalError "Type pattern info not added" Just vars -> do p <- currentPhase let rhs' = foldr (addScope p) stx @@ -1179,19 +1174,19 @@ problemCategory (TypePatternDest {}) = TypePatternCaseCat requireDeclarationCat :: Syntax -> MacroDest -> Expand (DeclTreePtr, DeclOutputScopesPtr) requireDeclarationCat _ (DeclTreeDest dest outScopesDest) = return (dest, outScopesDest) requireDeclarationCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon DeclarationCat) (mortise $ problemCategory other) requireTypeCat :: Syntax -> MacroDest -> Expand (Kind, SplitTypePtr) requireTypeCat _ (TypeDest kind dest) = return (kind, dest) requireTypeCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon TypeCat) (mortise $ problemCategory other) requireExpressionCat :: Syntax -> MacroDest -> Expand (Ty, SplitCorePtr) requireExpressionCat _ (ExprDest ty dest) = return (ty, dest) requireExpressionCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon ExpressionCat) (mortise $ problemCategory other) requirePatternCat :: Syntax -> MacroDest -> Expand (Either (Ty, PatternPtr) TypePatternPtr) @@ -1200,7 +1195,7 @@ requirePatternCat _ (PatternDest scrutTy dest) = requirePatternCat _ (TypePatternDest dest) = return $ Right dest requirePatternCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon PatternCaseCat) (mortise $ problemCategory other) @@ -1226,7 +1221,7 @@ expandOneForm prob stx _ <- mustBeIdent foundName argDests <- if length foundArgs /= length args' - then throwError $ + then debug $ WrongArgCount stx ctor (length args') (length foundArgs) else for (zip args' foundArgs) (uncurry schedule) linkExpr dest (CoreCtor ctor argDests) @@ -1238,7 +1233,7 @@ expandOneForm prob stx inst loc (Scheme argKinds a) tyArgs unify loc (tDatatype dt tyArgs) patTy if length subPats /= length argTypes - then throwError $ WrongArgCount stx ctor (length argTypes) (length subPats) + then debug $ WrongArgCount stx ctor (length argTypes) (length subPats) else do subPtrs <- for (zip subPats argTypes) \(sp, t) -> do ptr <- liftIO newPatternPtr @@ -1249,14 +1244,14 @@ expandOneForm prob stx linkPattern dest $ CtorPattern ctor subPtrs other -> - throwError $ + debug $ WrongSyntacticCategory stx (tenon ExpressionCat) (mortise $ problemCategory other) EPrimModuleMacro impl -> case prob of ModuleDest dest -> do impl dest stx other -> - throwError $ + debug $ WrongSyntacticCategory stx (tenon ModuleCat) (mortise $ problemCategory other) EPrimDeclMacro impl -> do (dest, outScopesDest) <- requireDeclarationCat stx prob @@ -1268,7 +1263,7 @@ expandOneForm prob stx TypePatternDest dest -> implP dest stx otherDest -> - throwError $ + debug $ WrongSyntacticCategory stx (tenon TypeCat) (mortise $ problemCategory otherDest) EPrimPatternMacro impl -> do dest <- requirePatternCat stx prob @@ -1297,7 +1292,7 @@ expandOneForm prob stx Id _ -> do equateKinds stx k k' linkType dest $ tSchemaVar i [] - _ -> throwError $ NotValidType stx + _ -> debug $ NotValidType stx EIncompleteDefn x n d -> do (t, dest) <- requireExpressionCat stx prob @@ -1316,10 +1311,7 @@ expandOneForm prob stx $ ValueSyntax $ addScope p stepScope stx case macroVal of - Left err -> throwError - $ ValueNotMacro - $ erroneousValue - $ projectError err + Left err -> debug $ ValueNotMacro err Right mv -> case mv of ValueMacroAction act -> interpretMacroAction prob act >>= \case @@ -1329,22 +1321,20 @@ expandOneForm prob stx case expanded of ValueSyntax expansionResult -> forkExpandSyntax prob (flipScope p stepScope expansionResult) - other -> throwError $ ValueNotSyntax other - other -> - throwError $ ValueNotMacro other - Nothing -> - throwError $ InternalError $ + other -> debug $ ValueNotSyntax other + other -> debug $ ValueNotMacro $ constructErrorType "error in user macro" other + Nothing -> debug $ InternalError $ "No transformer yet created for " ++ shortShow ident ++ " (" ++ show transformerName ++ ") at phase " ++ shortShow p - Just other -> throwError $ ValueNotMacro other + Just other -> debug $ ValueNotMacro $ constructErrorType "expected macro but got value" other | otherwise = case prob of ModuleDest {} -> - throwError $ InternalError "All modules should be identifier-headed" + debug $ InternalError "All modules should be identifier-headed" DeclTreeDest {} -> - throwError $ InternalError "All declarations should be identifier-headed" + debug $ InternalError "All declarations should be identifier-headed" TypeDest {} -> - throwError $ NotValidType stx + debug $ NotValidType stx ExprDest t dest -> case syntaxE stx of List xs -> expandOneExpression t dest (addApp stx xs) @@ -1352,9 +1342,9 @@ expandOneForm prob stx String s -> expandOneExpression t dest (addStringLiteral stx s) Id _ -> error "Impossible happened - identifiers are identifier-headed!" PatternDest {} -> - throwError $ InternalError "All patterns should be identifier-headed" + debug $ InternalError "All patterns should be identifier-headed" TypePatternDest {} -> - throwError $ InternalError "All type patterns should be identifier-headed" + debug $ InternalError "All type patterns should be identifier-headed" expandModuleForm :: DeclTreePtr -> Syntax -> Expand () @@ -1418,23 +1408,20 @@ interpretMacroAction prob = view (expanderWorld . worldEnvironments . at phase) $ s case applyInEnv env closure boundResult of -- FIXME DYG: what error to throw here - Left err -> throwError - $ ValueNotMacro - $ erroneousValue - $ projectError err + Left err -> debug $ ValueNotMacro err Right v -> case v of ValueMacroAction act -> interpretMacroAction prob act - other -> throwError $ ValueNotMacro other + other -> debug $ ValueNotMacro (Up other mempty Halt) MacroActionSyntaxError syntaxError -> - throwError $ MacroRaisedSyntaxError syntaxError + debug $ MacroRaisedSyntaxError syntaxError MacroActionIdentEq how v1 v2 -> do id1 <- getIdent v1 id2 <- getIdent v2 case how of Free -> compareFree id1 id2 - `catchError` + `catch` \case -- Ambiguous bindings should not crash the comparison - -- they're just not free-identifier=?. @@ -1442,7 +1429,7 @@ interpretMacroAction prob = -- Similarly, things that are not yet bound are just not -- free-identifier=? Unknown _ -> return $ Done $ primitiveCtor "false" [] - e -> throwError e + e -> debug e Bound -> return $ Done $ flip primitiveCtor [] $ if view stxValue id1 == view stxValue id2 && @@ -1450,7 +1437,7 @@ interpretMacroAction prob = then "true" else "false" where getIdent (ValueSyntax stx) = mustBeIdent stx - getIdent _other = throwError $ InternalError $ "Not a syntax object in " ++ opName + getIdent _other = debug $ InternalError $ "Not a syntax object in " ++ opName compareFree id1 id2 = do b1 <- resolve id1 b2 <- resolve id2 @@ -1467,7 +1454,7 @@ interpretMacroAction prob = MacroActionIntroducer -> do sc <- freshScope "User introduction scope" pure $ Done $ - ValueClosure $ HO \(ValueCtor ctor []) -> ValueClosure $ HO \(ValueSyntax stx) -> + ValueClosure $ HO "one" \(ValueCtor ctor []) -> ValueClosure $ HO "two" \(ValueSyntax stx) -> ValueSyntax case view (constructorName . constructorNameText) ctor of "add" -> addScope' sc stx diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index c4134733..0e5147d5 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Expander.Error @@ -50,8 +51,8 @@ data ExpansionErr | NotExportSpec Syntax | UnknownPattern Syntax | MacroRaisedSyntaxError (SyntaxError Syntax) - | MacroEvaluationError Phase EvalError - | ValueNotMacro Value + | MacroEvaluationError Phase EState + | ValueNotMacro EState | ValueNotSyntax Value | ImportError KlisterPathError | InternalError String diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 62f7ce3c..9622d7ba 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -155,9 +155,7 @@ import Control.Arrow import Control.Lens import Control.Monad import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Except (MonadError(throwError)) import Control.Monad.Reader (MonadReader(ask, local), asks) -import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.Foldable import Data.IORef @@ -176,6 +174,7 @@ import Binding.Info import Control.Lens.IORef import Core import Datatype +import Debugger import Env import Evaluator import Expander.DeclScope @@ -206,13 +205,14 @@ import qualified Util.Store as S import Util.Key newtype Expand a = Expand - { runExpand :: ReaderT ExpanderContext (ExceptT ExpansionErr IO) a + { runExpand :: ReaderT ExpanderContext (Debug DebugContext ExpansionErr) a } - deriving (Functor, Applicative, Monad, MonadError ExpansionErr, MonadIO, MonadReader ExpanderContext) + deriving (Functor, Applicative, Monad, MonadIO + , MonadDebugger ExpansionErr, MonadReader ExpanderContext + ) execExpand :: ExpanderContext -> Expand a -> IO (Either ExpansionErr a) -execExpand ctx act = runExceptT $ runReaderT (runExpand act) ctx - +execExpand ctx act = runDebug (runReaderT (runExpand act) ctx) initialContext newtype TaskID = TaskID Unique deriving newtype (Eq, Ord, HasKey) @@ -596,7 +596,7 @@ getDeclGroup :: DeclTreePtr -> Expand (Seq CompleteDecl) getDeclGroup ptr = (view (expanderCompletedDeclTrees . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Incomplete module after expansion" + Nothing -> debug $ InternalError "Incomplete module after expansion" Just DeclTreeLeaf -> pure mempty Just (DeclTreeAtom decl) -> pure <$> getDecl decl @@ -607,7 +607,7 @@ getDecl :: DeclPtr -> Expand CompleteDecl getDecl ptr = (view (expanderCompletedDecls . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Missing decl after expansion" + Nothing -> debug $ InternalError "Missing decl after expansion" Just decl -> zonkDecl decl where zonkDecl :: @@ -616,11 +616,11 @@ getDecl ptr = zonkDecl (Define x v schPtr e) = linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing expr after expansion" + Nothing -> debug $ InternalError "Missing expr after expansion" Just e' -> linkedScheme schPtr >>= \case - Nothing -> throwError $ InternalError "Missing scheme after expansion" + Nothing -> debug $ InternalError "Missing scheme after expansion" Just (Scheme ks t) -> do ks' <- traverse zonkKindDefault ks pure $ CompleteDecl $ Define x v (Scheme ks' t) e' @@ -629,7 +629,7 @@ getDecl ptr = for macros \(x, v, e) -> linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing expr after expansion" + Nothing -> debug $ InternalError "Missing expr after expansion" Just e' -> pure $ (x, v, e') zonkDecl (Data x dn argKinds ctors) = do argKinds' <- traverse zonkKindDefault argKinds @@ -645,7 +645,7 @@ getDecl ptr = linkedType ptr' >>= \case Nothing -> - throwError $ InternalError "Missing type after expansion" + debug $ InternalError "Missing type after expansion" Just argTy -> pure argTy pure (ident, cn, args') @@ -654,18 +654,18 @@ getDecl ptr = zonkDecl (Example loc schPtr e) = linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing expr after expansion" + Nothing -> debug . InternalError $ "Missing expr after expansion at: " <> show loc Just e' -> linkedScheme schPtr >>= \case - Nothing -> throwError $ InternalError "Missing example scheme after expansion" + Nothing -> debug . InternalError $ "Missing example scheme after expansion: " <> show loc Just (Scheme ks t) -> do ks' <- traverse zonkKindDefault ks pure $ CompleteDecl $ Example loc (Scheme ks' t) e' zonkDecl (Run loc e) = linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing action after expansion" + Nothing -> debug $ InternalError "Missing action after expansion" Just e' -> pure $ CompleteDecl $ Run loc e' zonkDecl (Import spec) = return $ CompleteDecl $ Import spec zonkDecl (Export x) = return $ CompleteDecl $ Export x @@ -772,7 +772,7 @@ constructorInfo ctor = do fromModule <- view (expanderCurrentConstructors . at p . non mempty . at ctor) <$> getState case fromWorld <|> fromModule of Nothing -> - throwError $ InternalError $ "Unknown constructor " ++ show ctor + debug $ InternalError $ "Unknown constructor " ++ show ctor Just info -> pure info datatypeInfo :: Datatype -> Expand DatatypeInfo @@ -782,7 +782,7 @@ datatypeInfo datatype = do fromModule <- view (expanderCurrentDatatypes . at p . non mempty . at datatype) <$> getState case fromWorld <|> fromModule of Nothing -> - throwError $ InternalError $ "Unknown datatype " ++ show datatype + debug $ InternalError $ "Unknown datatype " ++ show datatype Just info -> pure info bind :: Binding -> EValue -> Expand () @@ -848,7 +848,7 @@ completely body = do a <- body remainingTasks <- getTasks unless (null remainingTasks) $ do - throwError (NoProgress (map (view _3) remainingTasks)) + debug (NoProgress (map (view _3) remainingTasks)) setTasks oldTasks pure a @@ -864,11 +864,10 @@ clearTasks = modifyState $ set expanderTasks [] evalInCurrentPhase :: Core -> Expand Value evalInCurrentPhase evalAction = do env <- currentEnv - let out = evaluateIn env evalAction - case out of - Left err -> do + case evaluateIn env evalAction of + Left e_state -> do p <- currentPhase - throwError $ MacroEvaluationError p $ projectError err + debug $ MacroEvaluationError p e_state Right val -> return val currentTransformerEnv :: Expand TEnv @@ -927,7 +926,7 @@ importing mn act = do if mn `elem` inProgress then do here <- view (expanderWorld . worldLocation) <$> getState - throwError $ + debug $ CircularImports (relativizeModuleName here mn) $ fmap (relativizeModuleName here) inProgress else Expand $ local (over (expanderLocal . expanderImportStack) (mn:)) (runExpand act) diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index b8c5b8f8..72fe89b5 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS -Wno-name-shadowing #-} + module Expander.Primitives ( -- * Declaration primitives define @@ -73,6 +74,7 @@ import Numeric.Natural import Binding import Core import Datatype +import Debugger import qualified Env import Expander.DeclScope import Expander.Monad @@ -518,7 +520,7 @@ typeConstructor ctor argKinds = (implT, implP) implT k dest stx = do Stx _ _ (_, args) <- mustBeCons stx if length args > length argKinds - then throwError $ WrongTypeArity stx ctor + then debug $ WrongTypeArity stx ctor (fromIntegral $ length argKinds) (length args) else do @@ -530,7 +532,7 @@ typeConstructor ctor argKinds = (implT, implP) implP dest stx = do Stx _ _ (_, args) <- mustBeCons stx if length args > length argKinds - then throwError $ WrongTypeArity stx ctor + then debug $ WrongTypeArity stx ctor (fromIntegral $ length argKinds) (length args) else do @@ -588,7 +590,7 @@ makeLocalType dest stx = do _ <- mustBeIdent tstx linkType tdest $ TyF t [] let patImpl _ tstx = - throwError $ NotValidType tstx + debug $ NotValidType tstx p <- currentPhase addLocalBinding n b @@ -687,7 +689,7 @@ expandPatternCase t (Stx _ _ (lhs, rhs)) = do rhsDest <- schedule t rhs return (SyntaxPatternAny, rhsDest) other -> - throwError $ UnknownPattern other + debug $ UnknownPattern other scheduleDataPattern :: Ty -> Ty -> @@ -747,23 +749,23 @@ primitiveDatatype name args = unaryIntegerPrim :: (Integer -> Integer) -> Value unaryIntegerPrim f = - ValueClosure $ HO $ + ValueClosure $ HO "TODO:Jeff:WHAT-TO-PUT-HERE" $ \(ValueInteger i) -> ValueInteger (f i) binaryIntegerPrim :: (Integer -> Integer -> Integer) -> Value binaryIntegerPrim f = - ValueClosure $ HO $ + ValueClosure $ HO "bil" $ \(ValueInteger i1) -> - ValueClosure $ HO $ + ValueClosure $ HO "bir" $ \(ValueInteger i2) -> ValueInteger (f i1 i2) binaryIntegerPred :: (Integer -> Integer -> Bool) -> Value binaryIntegerPred f = - ValueClosure $ HO $ + ValueClosure $ HO "bipl" $ \(ValueInteger i1) -> - ValueClosure $ HO $ + ValueClosure $ HO "bipr" $ \(ValueInteger i2) -> if f i1 i2 then primitiveCtor "true" [] @@ -772,9 +774,9 @@ binaryIntegerPred f = binaryStringPred :: (Text -> Text -> Bool) -> Value binaryStringPred f = - ValueClosure $ HO $ + ValueClosure $ HO "bsp-l" $ \(ValueString str1) -> - ValueClosure $ HO $ + ValueClosure $ HO "bsp-r" $ \(ValueString str2) -> if f str1 str2 then primitiveCtor "true" [] diff --git a/src/Expander/Syntax.hs b/src/Expander/Syntax.hs index 2a3202b5..95e7911d 100644 --- a/src/Expander/Syntax.hs +++ b/src/Expander/Syntax.hs @@ -3,11 +3,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Utilities for analyzing the form of syntax in the expander monad module Expander.Syntax where -import Control.Monad.Except import Control.Monad.IO.Class import Data.Functor.Identity (Identity(Identity)) import Data.List (nub, sort) @@ -15,6 +15,7 @@ import Data.Text (Text) import qualified Data.Text as T import Numeric.Natural +import Debugger import Expander.Error import Expander.Monad import KlisterPath @@ -24,44 +25,44 @@ import Syntax mustBeIdent :: Syntax -> Expand (Stx Text) mustBeIdent (Syntax (Stx scs srcloc (Id x))) = return (Stx scs srcloc x) -mustBeIdent other = throwError (NotIdentifier other) +mustBeIdent other = debug (NotIdentifier other) mustBeEmpty :: Syntax -> Expand (Stx ()) mustBeEmpty (Syntax (Stx scs srcloc (List []))) = return (Stx scs srcloc ()) -mustBeEmpty other = throwError (NotEmpty other) +mustBeEmpty other = debug (NotEmpty other) mustBeCons :: Syntax -> Expand (Stx (Syntax, [Syntax])) mustBeCons (Syntax (Stx scs srcloc (List (x:xs)))) = return (Stx scs srcloc (x, xs)) -mustBeCons other = throwError (NotCons other) +mustBeCons other = debug (NotCons other) mustBeConsCons :: Syntax -> Expand (Stx (Syntax, Syntax, [Syntax])) mustBeConsCons (Syntax (Stx scs srcloc (List (x:y:xs)))) = return (Stx scs srcloc (x, y, xs)) -mustBeConsCons other = throwError (NotConsCons other) +mustBeConsCons other = debug (NotConsCons other) mustBeList :: Syntax -> Expand (Stx [Syntax]) mustBeList (Syntax (Stx scs srcloc (List xs))) = return (Stx scs srcloc xs) -mustBeList other = throwError (NotList other) +mustBeList other = debug (NotList other) mustBeInteger :: Syntax -> Expand (Stx Integer) mustBeInteger (Syntax (Stx scs srcloc (Integer n))) = return (Stx scs srcloc n) -mustBeInteger other = throwError (NotInteger other) +mustBeInteger other = debug (NotInteger other) mustBeString :: Syntax -> Expand (Stx Text) mustBeString (Syntax (Stx scs srcloc (String s))) = return (Stx scs srcloc s) -mustBeString other = throwError (NotString other) +mustBeString other = debug (NotString other) mustBeModName :: Syntax -> Expand (Stx ModuleName) mustBeModName (Syntax (Stx scs srcloc (String s))) = do kPath <- klisterPath liftIO (findModule kPath srcloc (T.unpack s)) >>= \case - Left err -> throwError (ImportError err) + Left err -> debug (ImportError err) Right path -> pure $ Stx scs srcloc path -- TODO use hygiene here instead mustBeModName (Syntax (Stx scs srcloc (Id "kernel"))) = return (Stx scs srcloc (KernelName kernelName)) -mustBeModName other = throwError (NotModName other) +mustBeModName other = debug (NotModName other) mustHaveEntries @@ -74,9 +75,9 @@ mustHaveEntries stx@(Syntax (Stx scs srcloc (List xs))) = do Right r -> do pure (Stx scs srcloc r) Left lengths -> do - throwError (NotRightLength lengths stx) + debug (NotRightLength lengths stx) mustHaveEntries other = do - throwError (NotList other) + debug (NotList other) class FixedLengthList item r where checkLength :: [item] -> Either [Natural] r @@ -141,8 +142,8 @@ instance MustHaveShape () where mustHaveShape (Syntax (Stx _ _ (List []))) = do pure () mustHaveShape other@(Syntax (Stx _ _ (List (_:_)))) = do - throwError (NotEmpty other) - mustHaveShape other = throwError (NotList other) + debug (NotEmpty other) + mustHaveShape other = debug (NotList other) instance ( MustHaveShape car , MustHaveShape cdr @@ -153,8 +154,8 @@ instance ( MustHaveShape car cdr <- mustHaveShape (Syntax (Stx scs srcloc (List xs))) pure (car, cdr) mustHaveShape other@(Syntax (Stx _ _ (List []))) = do - throwError (NotCons other) - mustHaveShape other = throwError (NotList other) + debug (NotCons other) + mustHaveShape other = debug (NotList other) instance MustHaveShape a => MustHaveShape [a] where mustHaveShape (Syntax (Stx _ _ (List []))) = do @@ -163,4 +164,4 @@ instance MustHaveShape a => MustHaveShape [a] where car <- mustHaveShape x cdr <- mustHaveShape (Syntax (Stx scs srcloc (List xs))) pure (car : cdr) - mustHaveShape other = throwError (NotList other) + mustHaveShape other = debug (NotList other) diff --git a/src/Expander/TC.hs b/src/Expander/TC.hs index f6fdf1b7..b9e5eb7a 100644 --- a/src/Expander/TC.hs +++ b/src/Expander/TC.hs @@ -11,13 +11,13 @@ module Expander.TC ( import Control.Lens hiding (indices) import Control.Monad -import Control.Monad.Except import Control.Monad.State import Data.Foldable import Numeric.Natural import Expander.Monad import Core +import Debugger import Datatype import Kind import SplitCore @@ -33,7 +33,7 @@ derefType :: MetaPtr -> Expand (TVar Ty) derefType ptr = (view (expanderTypeStore . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Dangling type metavar" + Nothing -> debug $ InternalError "Dangling type metavar" Just var -> pure var @@ -79,7 +79,7 @@ occursCheck ptr t = do if ptr `elem` free then do t' <- normAll t - throwError $ TypeCheckError $ OccursCheckFailed ptr t' + debug $ TypeCheckError $ OccursCheckFailed ptr t' else pure () pruneLevel :: Traversable f => BindingLevel -> f MetaPtr -> Expand () @@ -110,7 +110,7 @@ freshMeta kind = do inst :: UnificationErrorBlame blame => blame -> Scheme Ty -> [Ty] -> Expand Ty inst blame (Scheme argKinds ty) ts | length ts /= length argKinds = - throwError $ InternalError "Mismatch in number of type vars" + debug $ InternalError "Mismatch in number of type vars" | otherwise = do traverse_ (uncurry $ checkKind blame) (zip argKinds ts) instTy ty @@ -195,7 +195,7 @@ generalizeType ty = do Just j -> pure $ TSchemaVar j | otherwise = pure $ TMetaVar v genVarsCtor _ (TSchemaVar _) = - throwError $ InternalError "Can't generalize in scheme" + debug $ InternalError "Can't generalize in scheme" genVarsCtor _ ctor = pure ctor @@ -289,11 +289,11 @@ unifyWithBlame blame depth t1 t2 = do e' <- normAll $ Ty shouldBe r' <- normAll $ Ty received if depth == 0 - then throwError $ TypeCheckError $ TypeMismatch loc e' r' Nothing + then debug $ TypeCheckError $ TypeMismatch loc e' r' Nothing else do outerE' <- normAll outerExpected outerR' <- normAll outerReceived - throwError $ TypeCheckError $ TypeMismatch loc outerE' outerR' (Just (e', r')) + debug $ TypeCheckError $ TypeMismatch loc outerE' outerR' (Just (e', r')) linkVar ptr t = linkToType (view _1 blame) ptr t @@ -302,7 +302,7 @@ typeVarKind :: MetaPtr -> Expand Kind typeVarKind ptr = (view (expanderTypeStore . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Type variable not found!" + Nothing -> debug $ InternalError "Type variable not found!" Just v -> pure $ view varKind v @@ -324,7 +324,7 @@ equateKinds blame kind1 kind2 = k1' <- zonkKind kind1 k2' <- zonkKind kind2 loc <- getBlameLoc blame - throwError $ KindMismatch loc k1' k2' + debug $ KindMismatch loc k1' k2' where -- Rigid-rigid cases equateKinds' KStar KStar = pure True @@ -378,7 +378,7 @@ inferKind blame (Ty (TyF ctor args)) = do ctorKind (TDatatype dt) = do DatatypeInfo argKinds _ <- datatypeInfo dt pure $ kFun argKinds KStar - ctorKind (TSchemaVar _) = throwError $ InternalError "Tried to find kind in open context" + ctorKind (TSchemaVar _) = debug $ InternalError "Tried to find kind in open context" ctorKind (TMetaVar mv) = typeVarKind mv appKind k [] = pure k diff --git a/src/Pretty.hs b/src/Pretty.hs index 86b409bd..21d2fc96 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -2,11 +2,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -module Pretty (Doc, Pretty(..), string, text, viaShow, (<+>), (<>), align, hang, line, group, vsep, hsep, VarInfo(..), pretty, prettyPrint, prettyPrintLn, prettyEnv, prettyPrintEnv) where +module Pretty + ( Doc + , Pretty(..) + , ppBind + , string + , text + , viaShow + , (<+>), (<>), align, hang, line, group, vsep, hsep, hardline, nest + , VarInfo(..) + , pretty, prettyPrint, prettyPrintLn, prettyEnv, prettyPrintEnv + ) where import Control.Lens hiding (List) import Control.Monad.State @@ -26,7 +37,7 @@ import Binding.Info import Core import Datatype import Env -import Evaluator (EvalResult(..), EvalError(..), TypeError(..)) +import Evaluator (EvalResult(..), EvalError(..), TypeError(..), Kont(..), EState(..)) import Kind import Module import ModuleName @@ -137,6 +148,7 @@ instance (PrettyBinder VarInfo typePat, PrettyBinder VarInfo pat, Pretty VarInfo ] pp _env (CoreString str) = text (T.pack (show str)) pp env (CoreError what) = + -- set error to bold and red text "error" <+> pp env what pp env (CorePureMacro arg) = text "pure" <+> pp env arg @@ -201,7 +213,7 @@ class PrettyBinder ann a | a -> ann where instance PrettyBinder VarInfo a => PrettyBinder VarInfo (TyF a) where ppBind env t = let subs = ppBind env <$> t - in (pp env (fst <$> subs), foldMap snd subs) + in (pp env (fst <$> subs), foldMap snd subs) newtype BinderPair = BinderPair (Ident, Var) @@ -511,7 +523,8 @@ instance Pretty VarInfo (ExprF Syntax) where pp env (List xs) = parens (group (vsep (map (pp env . syntaxE) xs))) instance Pretty VarInfo Closure where - pp _ _ = text "#" + pp _ (FO fo) = "#<" <> text (_stxValue (_closureIdent fo)) <> ">" + pp _ (HO n _) = "#<" <> text n <> ">" instance Pretty VarInfo Value where pp env (ValueClosure c) = pp env c @@ -626,6 +639,7 @@ instance Pretty VarInfo EvalError where group $ hang 2 $ vsep [pp env loc <> ":", pp env msg] pp env (EvalErrorIdent v) = text "Attempt to bind identifier to non-value: " <+> pp env v + instance Pretty VarInfo EvalResult where pp env (ExampleResult loc valEnv coreExpr sch val) = let varEnv = fmap (const ()) valEnv @@ -675,3 +689,146 @@ instance Pretty VarInfo ScopeSet where instance Pretty VarInfo KlisterPathError where pp _ = ppKlisterPathError + +-- ----------------------------------------------------------------------------- +-- StackTraces + +instance Pretty VarInfo EState where + pp env st = printStack env st + +instance Pretty VarInfo Kont where + pp env k = hardline <> text "----" <+> printKont env k + +printStack :: Env Var () -> EState -> Doc VarInfo +printStack e (Er err _env k) = + vsep [ pp e err + , text "stack trace:" + ] <> pp e k +printStack _ Up{} = hang 2 $ text "up" +printStack _ Down{} = hang 2 $ text "down" + +printKont :: Env Var () -> Kont -> Doc VarInfo +-- the basics +printKont _ Halt = text "Halt" +printKont e (InPrim prim k) = text "in prim" <+> pp e prim <> pp e k +printKont e (InFun arg _env k) = text "with arg" <+> pp e arg <> pp e k +printKont e (InArg fun _env k) = text "with function" <+> pp e fun <> pp e k +printKont e (InLetDef name _var _body _env k) = text "in let" <+> pp e name + -- TODO: the body prints out uniques instead of the var name + -- <> pp e body + <> pp e k + +-- constructors +printKont e (InCtor field_vals con _f_to_process _env k) = + let position = length field_vals + 1 + in text "in constructor" <+> + align (vsep [pp e con, text "in field" <+> viaShow position]) <> pp e k + +-- cases +printKont e (InCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in case" <> pp e loc <> foldMap do_case cases <> pp e k +-- TODO: DYG: is data|type case different than case in the concrete syntax? +printKont e (InDataCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in data case" <> pp e loc <> foldMap do_case cases <> pp e k +printKont e (InTypeCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in type case" <> pp e loc <> foldMap do_case cases <> pp e k +printKont e (InCasePattern p k) = + let ppPattern = \case + SyntaxPatternIdentifier i _ -> pp e i + SyntaxPatternInteger i _ -> pp e i + SyntaxPatternString i _ -> pp e i + SyntaxPatternCons il _iv rl _rv -> pp e il <> pp e rl + SyntaxPatternList ls -> foldMap (\(i, _) -> pp e i) ls + SyntaxPatternAny -> text "_" + SyntaxPatternEmpty -> text "()" + in text "in case pattern" <> ppPattern p <> pp e k +printKont e (InDataCasePattern p k) = + let ppPattern = \case + CtorPattern c _ps -> pp e c + PatternVar i _v -> pp e i + in text "in data case pattern: " + <> ppPattern (unConstructorPattern p) + <> pp e k + +-- pairs +-- TODO: DYG: how to test the cons? +printKont e (InConsHd scope hd _env k) = + vsep [ text "in head of pair" + , nest 2 $ pp e hd + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InConsTl scope hd _env k) = + vsep [ text "in tail of pair" + , nest 2 $ pp e hd + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k + +-- lists +printKont e (InList scope _todos dones _env k) = + vsep [ text "in list" + , nest 2 $ foldMap (pp e) dones + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k + +-- idents +-- TODO: DYG: how to report and test these? +printKont e (InIdent scope _env k) = + vsep [ text "in ident" + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InIdentEqL _how scope _env k) = + vsep [ text "in ident eq left" + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InIdentEqR other _how _env k) = + vsep [ text "in ident eq right, comparing: " <> pp e other + ] + <> pp e k + +-- macros +printKont e (InPureMacro _env k) = + vsep [ text "in pure macro" -- TODO: needs a passthrough? + ] + <> pp e k +printKont e (InBindMacroHd tl _env k) = + vsep [ text "in bind macro head" -- TODO: needs a passthrough? + , pp e tl + ] + <> pp e k +printKont e (InBindMacroTl action _env k) = + vsep [ text "in bind macro tail" -- TODO: needs a passthrough? + , pp e action + ] + <> pp e k + +-- atomics +printKont e (InInteger _ _ k) = pp e k +printKont e (InString _ _ k) = pp e k +printKont e (InReplaceLocL _ _ k) = pp e k +printKont e (InReplaceLocR _ _ k) = pp e k + +-- scope +printKont e (InScope scope _env k) = + vsep [ text "in scope" + , pp e scope + ] + <> pp e k + +-- others +printKont e (InLog _ k) = pp e k -- would require a passthrough +printKont e (InError _ k) = pp e k +printKont e (InSyntaxErrorMessage _ _ k) = pp e k +printKont e (InSyntaxErrorLocations _ _ _ _ k) = pp e k diff --git a/src/StackTraces.hs b/src/StackTraces.hs new file mode 100644 index 00000000..c646c2bd --- /dev/null +++ b/src/StackTraces.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : StackTraces +-- Copyright : (c) David Thrane Christiansen +-- Samuel Gélineau +-- Jeffrey M. Young +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Samuel Gélineau +-- David Christiansen +-- Stability : experimental +-- +-- Converting state from the CEK machine to stack trace +----------------------------------------------------------------------------- + + +module StackTraces where + +import Evaluator +import Pretty + + +-- ----------------------------------------------------------------------------- +-- Top level API + +type StackTrace = EState + +printStack :: StackTrace -> Doc ann +printStack (Er err env k) = hang 2 $ + printErr err + +printKont :: Kont -> Doc ann +printKont = align . vsep + +printErr :: EvalError -> Doc ann +printErr = pretty + +printEnv :: VEnv -> Doc ann +printEnv = pretty diff --git a/src/Value.hs b/src/Value.hs index a6629458..12048035 100644 --- a/src/Value.hs +++ b/src/Value.hs @@ -52,7 +52,11 @@ primitiveCtor name args = in ValueCtor ctor args valueText :: Value -> Text -valueText (ValueClosure _) = "#" +valueText (ValueClosure c) = "#<" <> the_closure <> ">" + where + the_closure = case c of + (FO fo) -> _stxValue $ _closureIdent fo + (HO n _) -> n valueText (ValueSyntax stx) = "'" <> syntaxText stx valueText (ValueMacroAction _) = "#" valueText (ValueIOAction _) = "#" @@ -84,10 +88,11 @@ data FOClosure = FOClosure , _closureBody :: Core } -data Closure = FO FOClosure | HO (Value -> Value) +data Closure = FO FOClosure | HO Text (Value -> Value) instance Show Closure where - show _ = "Closure {...}" + show (FO fo) = "Closure {" <> show (_closureIdent fo) <> "}" + show (HO name _) = "Closure {" <> show name <> "}" makePrisms ''MacroAction makePrisms ''Value