Merge pull request #54 from LunNova/lunnova/augment-reducer-errors

metalanguage: augment reducer errors with anchors

alicorn-expressions.lua

@@ -390,6 +390,36 @@ end, "expressions")
 --   return self.val(ops, env)
 -- end
 
+---@class OperativeError
+---@field cause any
+---@field anchor any
+---@field operative_name string
+local OperativeError = {}
+local external_error_mt = {
+	__tostring = function(self)
+		local message = "Lua error occured inside primitive operative "
+			.. self.operative_name
+			.. " "
+			.. (self.anchor and tostring(self.anchor) or " at unknown position")
+			.. ":\n"
+			.. tostring(self.cause)
+		return message
+	end,
+	__index = OperativeError,
+}
+
+---@param cause any
+---@param anchor any
+---@param operative_name any
+---@return OperativeError
+function OperativeError.new(cause, anchor, operative_name)
+	return setmetatable({
+		anchor = anchor,
+		cause = cause,
+		operative_name = operative_name,
+	}, external_error_mt)
+end
+
 ---@param fn fun(syntax : any, env : Environment) : boolean, any, Environment
 ---@param name string
 ---@return inferrable_term.operative_cons
@@ -406,12 +436,7 @@ local function primitive_operative(fn, name)
 		end
 		local ok, res, env = fn(syn, env)
 		if not ok then
-			error(
-				"Primitive operative "
-					.. debugstring
-					.. " apply failure, NYI convert to Maybe.\nError was:"
-					.. tostring(res)
-			)
+			error(OperativeError.new(res, syn.anchor, debugstring))
 		end
 		if not env or not env.exit_block then
 			print(

evaluator.lua

@@ -1629,7 +1629,12 @@ function evaluate(typed_term, runtime_context)
 		local content = typed_term:unwrap_prim_box()
 		return value.prim(evaluate(content, runtime_context))
 	elseif typed_term:is_prim_unbox() then
-		local ok, prim = typed_term:unwrap_prim_unbox():as_prim()
+		local unwrapped = typed_term:unwrap_prim_unbox()
+		if not unwrapped.as_prim then
+			print("unwrapped", unwrapped)
+			error "evaluate, is_prim_unbox: missing as_prim on unwrapped prim_unbox"
+		end
+		local ok, prim = unwrapped:as_prim()
 		if not ok then
 			error "evaluate, is_prim_unbox: expected a prim"
 		end

metalanguage.lua

@@ -68,9 +68,47 @@ end
 
 local reducer_mt = { __call = create_reducible }
 
+---@class ExternalError
+---@field cause any
+---@field anchor any
+---@field reducer_name string
+local ExternalError = {}
+local external_error_mt = {
+	__tostring = function(self)
+		local message = "Lua error raised inside reducer "
+			.. self.reducer_name
+			.. " "
+			.. (self.anchor and tostring(self.anchor) or "at unknown position")
+			.. ":\n"
+			.. tostring(self.cause)
+		return message
+	end,
+	__index = ExternalError,
+}
+
+---@param cause any
+---@param anchor any
+---@param reducer_name any
+---@return ExternalError
+function ExternalError.new(cause, anchor, reducer_name)
+	return setmetatable({
+		anchor = anchor,
+		cause = cause,
+		reducer_name = reducer_name,
+	}, external_error_mt)
+end
+
+local function augment_error(syntax, reducer_name, ok, err_msg, ...)
+	if not ok then
+		return false, ExternalError.new(err_msg, syntax.anchor, reducer_name)
+	end
+	-- err_msg is the first result arg otherwise
+	return err_msg, ...
+end
+
 local function reducer(func, name)
 	local function funcwrapper(syntax, matcher)
-		return func(syntax, table.unpack(matcher.reducible))
+		return augment_error(syntax, name, xpcall(func, debug.traceback, syntax, table.unpack(matcher.reducible)))
 	end
 
 	local reducer = {

runtest.lua

@@ -7,11 +7,12 @@ local terms = require "./terms"
 local exprs = require "./alicorn-expressions"
 local fs = require "fs"
 
-local src = fs.readFileSync("testfile.alc")
+local filename = "testfile.alc"
+local src = fs.readFileSync(filename)
 print("read code")
 print(src)
 print("parsing code")
-local code = format.read(src, "inline")
+local code = format.read(src, filename)
 -- p(code)
 
 local env = base_env.create()

testfile.alc

@@ -41,7 +41,7 @@ let prim-array-set =
 				array[index] = elem
 			end
 		:
-		prim-func-type (T : (boxed prim-type)) (arr : (array-type T)) (index : prim-number) (elem : (unbox prim-type T)) ->
+		prim-func-type (T : (boxed prim-type)) (arr : (array-type (unbox prim-type T))) (index : prim-number) (elem : (unbox prim-type T)) ->
 
 let prim-array-get = 
 	intrinsic