Merge pull request #1047 from quantified-uncertainty/exceptional-reducer

Exceptional reducer (~20% speedup)
This commit is contained in:
Ozzie Gooen 2022-09-11 08:09:51 -07:00 committed by GitHub
commit 5772c458a8
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
21 changed files with 217 additions and 243 deletions

View File

@ -19,7 +19,7 @@ let testMacro_ = (
let bindings = Bindings.fromArray(bindArray) let bindings = Bindings.fromArray(bindArray)
tester(expr->T.toString, () => tester(expr->T.toString, () =>
expr expr
->Macro.expandMacroCall( ->Macro.expandMacroCallRs(
bindings, bindings,
ProjectAccessorsT.identityAccessors, ProjectAccessorsT.identityAccessors,
Expression.reduceExpressionInProject, Expression.reduceExpressionInProject,
@ -44,6 +44,7 @@ let testMacroEval_ = (
ProjectAccessorsT.identityAccessors, ProjectAccessorsT.identityAccessors,
Expression.reduceExpressionInProject, Expression.reduceExpressionInProject,
) )
->Ok
->InternalExpressionValue.toStringResult ->InternalExpressionValue.toStringResult
->expect ->expect
->toEqual(expectedValue) ->toEqual(expectedValue)

View File

@ -16,7 +16,7 @@ let checkArgumentsSourceCode = (aTypeSourceCode: string, sourceCode: string): re
> => { > => {
let reducerFn = Expression.reduceExpressionInProject let reducerFn = Expression.reduceExpressionInProject
let rResult = let rResult =
Expression.BackCompatible.parse(sourceCode)->Belt.Result.flatMap(expr => Expression.BackCompatible.parse(sourceCode)->Belt.Result.map(expr =>
reducerFn(expr, Bindings.emptyBindings, ProjectAccessorsT.identityAccessors) reducerFn(expr, Bindings.emptyBindings, ProjectAccessorsT.identityAccessors)
) )
rResult->Belt.Result.flatMap(result => rResult->Belt.Result.flatMap(result =>

View File

@ -19,7 +19,7 @@ let isTypeOfSourceCode = (aTypeSourceCode: string, sourceCode: string): result<
> => { > => {
let reducerFn = Expression.reduceExpressionInProject let reducerFn = Expression.reduceExpressionInProject
let rResult = let rResult =
Expression.BackCompatible.parse(sourceCode)->Belt.Result.flatMap(expr => Expression.BackCompatible.parse(sourceCode)->Belt.Result.map(expr =>
reducerFn(expr, Bindings.emptyBindings, ProjectAccessorsT.identityAccessors) reducerFn(expr, Bindings.emptyBindings, ProjectAccessorsT.identityAccessors)
) )
rResult->Belt.Result.flatMap(result => TypeChecker.isTypeOf(aTypeSourceCode, result, reducerFn)) rResult->Belt.Result.flatMap(result => TypeChecker.isTypeOf(aTypeSourceCode, result, reducerFn))

View File

@ -56,7 +56,7 @@ describe("test exceptions", () => {
testDescriptionEvalToBe( testDescriptionEvalToBe(
"javascript exception", "javascript exception",
"javascriptraise('div by 0')", "javascriptraise('div by 0')",
"Error(JS Exception: Error: 'div by 0')", "Error(Error: 'div by 0')",
) )
// testDescriptionEvalToBe( // testDescriptionEvalToBe(
// "rescript exception", // "rescript exception",

View File

@ -74,12 +74,11 @@ module Integration = {
reducer, reducer,
) )
let result = switch resultAsInternalExpression { let result = switch resultAsInternalExpression {
| Ok(IEvNumber(x)) => Ok(x) | IEvNumber(x) => Ok(x)
| Error(_) => | _ =>
Error( Error(
"Error 1 in Danger.integrate. It's possible that your function doesn't return a number, try definining auxiliaryFunction(x) = mean(yourFunction(x)) and integrate auxiliaryFunction instead", "Error 1 in Danger.integrate. It's possible that your function doesn't return a number, try definining auxiliaryFunction(x) = mean(yourFunction(x)) and integrate auxiliaryFunction instead",
) )
| _ => Error("Error 2 in Danger.integrate")
} }
result result
} }
@ -143,7 +142,7 @@ module Integration = {
} }
| Error(b) => | Error(b) =>
Error( Error(
"Integration error 3 in Danger.integrate. It's possible that your function doesn't return a number, try definining auxiliaryFunction(x) = mean(yourFunction(x)) and integrate auxiliaryFunction instead." ++ "Integration error 2 in Danger.integrate. It's possible that your function doesn't return a number, try definining auxiliaryFunction(x) = mean(yourFunction(x)) and integrate auxiliaryFunction instead." ++
"Original error: " ++ "Original error: " ++
b, b,
) )
@ -309,14 +308,10 @@ module DiminishingReturns = {
reducer, reducer,
) )
switch resultAsInternalExpression { switch resultAsInternalExpression {
| Ok(IEvNumber(x)) => Ok(x) | IEvNumber(x) => Ok(x)
| Error(_) =>
Error(
"Error 1 in Danger.optimalAllocationGivenDiminishingMarginalReturnsForManyFunctions. It's possible that your function doesn't return a number, try definining auxiliaryFunction(x) = mean(yourFunction(x)) and integrate auxiliaryFunction instead",
)
| _ => | _ =>
Error( Error(
"Error 2 in Danger.optimalAllocationGivenDiminishingMarginalReturnsForManyFunctions", "Error 1 in Danger.optimalAllocationGivenDiminishingMarginalReturnsForManyFunctions. It's possible that your function doesn't return a number, try definining auxiliaryFunction(x) = mean(yourFunction(x)) and integrate auxiliaryFunction instead",
) )
} }
} }

View File

@ -32,19 +32,17 @@ module Internals = {
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
eLambdaValue, eLambdaValue,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
): result<ReducerInterface_InternalExpressionValue.t, Reducer_ErrorValue.errorValue> => { ): ReducerInterface_InternalExpressionValue.t => {
let rMappedList = array->E.A.reduceReverse(Ok(list{}), (rAcc, elem) => let mappedList = array->E.A.reduceReverse(list{}, (acc, elem) => {
rAcc->E.R.bind(_, acc => { let newElem = Reducer_Expression_Lambda.doLambdaCall(
let rNewElem = Reducer_Expression_Lambda.doLambdaCall(
eLambdaValue, eLambdaValue,
list{elem}, list{elem},
(accessors: ProjectAccessorsT.t), (accessors: ProjectAccessorsT.t),
(reducer: ProjectReducerFnT.t), (reducer: ProjectReducerFnT.t),
) )
rNewElem->E.R2.fmap(newElem => list{newElem, ...acc}) list{newElem, ...acc}
}) })
) mappedList->Belt.List.toArray->Wrappers.evArray
rMappedList->E.R2.fmap(mappedList => mappedList->Belt.List.toArray->Wrappers.evArray)
} }
let reduce = ( let reduce = (
@ -54,11 +52,9 @@ module Internals = {
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
) => { ) => {
aValueArray->E.A.reduce(Ok(initialValue), (rAcc, elem) => aValueArray->E.A.reduce(initialValue, (acc, elem) =>
rAcc->E.R.bind(_, acc =>
Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list{acc, elem}, accessors, reducer) Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list{acc, elem}, accessors, reducer)
) )
)
} }
let reduceReverse = ( let reduceReverse = (
@ -68,11 +64,9 @@ module Internals = {
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
) => { ) => {
aValueArray->Belt.Array.reduceReverse(Ok(initialValue), (rAcc, elem) => aValueArray->Belt.Array.reduceReverse(initialValue, (acc, elem) =>
rAcc->Belt.Result.flatMap(acc =>
Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list{acc, elem}, accessors, reducer) Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list{acc, elem}, accessors, reducer)
) )
)
} }
let filter = ( let filter = (
@ -81,25 +75,19 @@ module Internals = {
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
) => { ) => {
let rMappedList = aValueArray->Belt.Array.reduceReverse(Ok(list{}), (rAcc, elem) => let mappedList = aValueArray->Belt.Array.reduceReverse(list{}, (acc, elem) => {
rAcc->E.R.bind(_, acc => { let newElem = Reducer_Expression_Lambda.doLambdaCall(
let rNewElem = Reducer_Expression_Lambda.doLambdaCall(
aLambdaValue, aLambdaValue,
list{elem}, list{elem},
accessors, accessors,
reducer, reducer,
) )
rNewElem->E.R2.fmap(newElem => {
switch newElem { switch newElem {
| IEvBool(true) => list{elem, ...acc} | IEvBool(true) => list{elem, ...acc}
| _ => acc | _ => acc
} }
}) })
}) mappedList->Belt.List.toArray->Wrappers.evArray
)
let result =
rMappedList->E.R2.fmap(mappedList => mappedList->Belt.List.toArray->Wrappers.evArray)
result
} }
} }
@ -216,7 +204,7 @@ let library = [
~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer) => ~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer) =>
switch inputs { switch inputs {
| [IEvArray(array), IEvLambda(lambda)] => | [IEvArray(array), IEvLambda(lambda)] =>
Internals.map(array, accessors, lambda, reducer)->E.R2.errMap(_ => "Error!") Ok(Internals.map(array, accessors, lambda, reducer))
| _ => Error(impossibleError) | _ => Error(impossibleError)
}, },
(), (),
@ -236,9 +224,7 @@ let library = [
~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer) => ~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer) =>
switch inputs { switch inputs {
| [IEvArray(array), initialValue, IEvLambda(lambda)] => | [IEvArray(array), initialValue, IEvLambda(lambda)] =>
Internals.reduce(array, initialValue, lambda, accessors, reducer)->E.R2.errMap(_ => Ok(Internals.reduce(array, initialValue, lambda, accessors, reducer))
"Error!"
)
| _ => Error(impossibleError) | _ => Error(impossibleError)
}, },
(), (),
@ -258,13 +244,7 @@ let library = [
~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer: ProjectReducerFnT.t) => ~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer: ProjectReducerFnT.t) =>
switch inputs { switch inputs {
| [IEvArray(array), initialValue, IEvLambda(lambda)] => | [IEvArray(array), initialValue, IEvLambda(lambda)] =>
Internals.reduceReverse( Ok(Internals.reduceReverse(array, initialValue, lambda, accessors, reducer))
array,
initialValue,
lambda,
accessors,
reducer,
)->E.R2.errMap(_ => "Error!")
| _ => Error(impossibleError) | _ => Error(impossibleError)
}, },
(), (),
@ -284,7 +264,7 @@ let library = [
~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer: ProjectReducerFnT.t) => ~run=(inputs, _, accessors: ProjectAccessorsT.t, reducer: ProjectReducerFnT.t) =>
switch inputs { switch inputs {
| [IEvArray(array), IEvLambda(lambda)] => | [IEvArray(array), IEvLambda(lambda)] =>
Internals.filter(array, lambda, accessors, reducer)->E.R2.errMap(_ => "Error!") Ok(Internals.filter(array, lambda, accessors, reducer))
| _ => Error(impossibleError) | _ => Error(impossibleError)
}, },
(), (),

View File

@ -37,7 +37,7 @@ module Internal = {
let doLambdaCall = (aLambdaValue, list, environment, reducer) => let doLambdaCall = (aLambdaValue, list, environment, reducer) =>
switch Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list, environment, reducer) { switch Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list, environment, reducer) {
| Ok(IEvNumber(f)) => Ok(f) | IEvNumber(f) => Ok(f)
| _ => Error(Operation.SampleMapNeedsNtoNFunction) | _ => Error(Operation.SampleMapNeedsNtoNFunction)
} }

View File

@ -16,7 +16,7 @@ module Internal = {
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
) => ) =>
switch Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list, accessors, reducer) { switch Reducer_Expression_Lambda.doLambdaCall(aLambdaValue, list, accessors, reducer) {
| Ok(IEvNumber(f)) => Ok(f) | IEvNumber(f) => Ok(f)
| _ => Error(Operation.SampleMapNeedsNtoNFunction) | _ => Error(Operation.SampleMapNeedsNtoNFunction)
} }

View File

@ -3,6 +3,7 @@ module BindingsReplacer = Reducer_Expression_BindingsReplacer
module Continuation = ReducerInterface_Value_Continuation module Continuation = ReducerInterface_Value_Continuation
module ExpressionT = Reducer_Expression_T module ExpressionT = Reducer_Expression_T
module ExternalLibrary = ReducerInterface.ExternalLibrary module ExternalLibrary = ReducerInterface.ExternalLibrary
module InternalExpressionValue = ReducerInterface_InternalExpressionValue
module Lambda = Reducer_Expression_Lambda module Lambda = Reducer_Expression_Lambda
module MathJs = Reducer_MathJs module MathJs = Reducer_MathJs
module ProjectAccessorsT = ReducerProject_ProjectAccessors_T module ProjectAccessorsT = ReducerProject_ProjectAccessors_T
@ -111,7 +112,7 @@ let callInternal = (
module SampleMap = { module SampleMap = {
let doLambdaCall = (aLambdaValue, list) => let doLambdaCall = (aLambdaValue, list) =>
switch Lambda.doLambdaCall(aLambdaValue, list, accessors, reducer) { switch Lambda.doLambdaCall(aLambdaValue, list, accessors, reducer) {
| Ok(IEvNumber(f)) => Ok(f) | IEvNumber(f) => Ok(f)
| _ => Error(Operation.SampleMapNeedsNtoNFunction) | _ => Error(Operation.SampleMapNeedsNtoNFunction)
} }
@ -201,13 +202,17 @@ let dispatch = (
call: functionCall, call: functionCall,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
): result<internalExpressionValue, errorValue> => ): internalExpressionValue =>
try { try {
let (fn, args) = call let (fn, args) = call
// There is a bug that prevents string match in patterns // There is a bug that prevents string match in patterns
// So we have to recreate a copy of the string // So we have to recreate a copy of the string
ExternalLibrary.dispatch((Js.String.make(fn), args), accessors, reducer, callInternal) ExternalLibrary.dispatch(
(Js.String.make(fn), args),
accessors,
reducer,
callInternal,
)->InternalExpressionValue.resultToValue
} catch { } catch {
| Js.Exn.Error(obj) => REJavaScriptExn(Js.Exn.message(obj), Js.Exn.name(obj))->Error | exn => Reducer_ErrorValue.fromException(exn)->Reducer_ErrorValue.toException
| _ => RETodo("unhandled rescript exception")->Error
} }

View File

@ -12,11 +12,9 @@ module ExpressionWithContext = Reducer_ExpressionWithContext
module InternalExpressionValue = ReducerInterface_InternalExpressionValue module InternalExpressionValue = ReducerInterface_InternalExpressionValue
module ProjectAccessorsT = ReducerProject_ProjectAccessors_T module ProjectAccessorsT = ReducerProject_ProjectAccessors_T
module ProjectReducerFnT = ReducerProject_ReducerFn_T module ProjectReducerFnT = ReducerProject_ReducerFn_T
module Result = Belt.Result
open Reducer_Expression_ExpressionBuilder open Reducer_Expression_ExpressionBuilder
type errorValue = ErrorValue.errorValue
type expression = ExpressionT.expression type expression = ExpressionT.expression
type expressionWithContext = ExpressionWithContext.expressionWithContext type expressionWithContext = ExpressionWithContext.expressionWithContext
@ -25,21 +23,15 @@ let dispatchMacroCall = (
bindings: ExpressionT.bindings, bindings: ExpressionT.bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reduceExpression: ProjectReducerFnT.t, reduceExpression: ProjectReducerFnT.t,
): result<expressionWithContext, errorValue> => { ): expressionWithContext => {
let useExpressionToSetBindings = (bindingExpr: expression, accessors, statement, newCode) => { let useExpressionToSetBindings = (bindingExpr: expression, accessors, statement, newCode) => {
let rExternalBindingsValue = reduceExpression(bindingExpr, bindings, accessors) let nameSpaceValue = reduceExpression(bindingExpr, bindings, accessors)
rExternalBindingsValue->Result.flatMap(nameSpaceValue => {
let newBindings = Bindings.fromExpressionValue(nameSpaceValue) let newBindings = Bindings.fromExpressionValue(nameSpaceValue)
let rNewStatement = BindingsReplacer.replaceSymbols(newBindings, statement) let boundStatement = BindingsReplacer.replaceSymbols(newBindings, statement)
rNewStatement->Result.map(boundStatement =>
ExpressionWithContext.withContext( ExpressionWithContext.withContext(newCode(newBindings->eModule, boundStatement), newBindings)
newCode(newBindings->eModule, boundStatement),
newBindings,
)
)
})
} }
let correspondingSetBindingsFn = (fnName: string): string => let correspondingSetBindingsFn = (fnName: string): string =>
@ -52,7 +44,7 @@ let dispatchMacroCall = (
} }
let doBindStatement = (bindingExpr: expression, statement: expression, accessors) => { let doBindStatement = (bindingExpr: expression, statement: expression, accessors) => {
let defaultStatement = ErrorValue.REAssignmentExpected->Error let defaultStatement = ErrorValue.REAssignmentExpected
switch statement { switch statement {
| ExpressionT.EList(list{ExpressionT.EValue(IEvCall(callName)), symbolExpr, statement}) => { | ExpressionT.EList(list{ExpressionT.EValue(IEvCall(callName)), symbolExpr, statement}) => {
let setBindingsFn = correspondingSetBindingsFn(callName) let setBindingsFn = correspondingSetBindingsFn(callName)
@ -62,17 +54,18 @@ let dispatchMacroCall = (
boundStatement, boundStatement,
) => eFunction(setBindingsFn, list{newBindingsExpr, symbolExpr, boundStatement})) ) => eFunction(setBindingsFn, list{newBindingsExpr, symbolExpr, boundStatement}))
} else { } else {
defaultStatement defaultStatement->Reducer_ErrorValue.toException
} }
} }
| _ => defaultStatement | _ => defaultStatement->Reducer_ErrorValue.toException
} }
} }
let doBindExpression = (bindingExpr: expression, statement: expression, accessors): result< let doBindExpression = (
expressionWithContext, bindingExpr: expression,
errorValue, statement: expression,
> => { accessors,
): expressionWithContext => {
let defaultStatement = () => let defaultStatement = () =>
useExpressionToSetBindings(bindingExpr, accessors, statement, ( useExpressionToSetBindings(bindingExpr, accessors, statement, (
_newBindingsExpr, _newBindingsExpr,
@ -100,10 +93,11 @@ let dispatchMacroCall = (
} }
} }
let doBlock = (exprs: list<expression>, _bindings: ExpressionT.bindings, _accessors): result< let doBlock = (
expressionWithContext, exprs: list<expression>,
errorValue, _bindings: ExpressionT.bindings,
> => { _accessors,
): expressionWithContext => {
let exprsArray = Belt.List.toArray(exprs) let exprsArray = Belt.List.toArray(exprs)
let maxIndex = Js.Array2.length(exprsArray) - 1 let maxIndex = Js.Array2.length(exprsArray) - 1
let newStatement = exprsArray->Js.Array2.reducei((acc, statement, index) => let newStatement = exprsArray->Js.Array2.reducei((acc, statement, index) =>
@ -119,14 +113,14 @@ let dispatchMacroCall = (
eBindStatement(acc, statement) eBindStatement(acc, statement)
} }
, eSymbol("undefined block")) , eSymbol("undefined block"))
ExpressionWithContext.noContext(newStatement)->Ok ExpressionWithContext.noContext(newStatement)
} }
let doLambdaDefinition = ( let doLambdaDefinition = (
bindings: ExpressionT.bindings, bindings: ExpressionT.bindings,
parameters: array<string>, parameters: array<string>,
lambdaDefinition: ExpressionT.expression, lambdaDefinition: ExpressionT.expression,
) => ExpressionWithContext.noContext(eLambda(parameters, bindings, lambdaDefinition))->Ok ) => ExpressionWithContext.noContext(eLambda(parameters, bindings, lambdaDefinition))
let doTernary = ( let doTernary = (
condition: expression, condition: expression,
@ -134,28 +128,28 @@ let dispatchMacroCall = (
ifFalse: expression, ifFalse: expression,
bindings: ExpressionT.bindings, bindings: ExpressionT.bindings,
accessors, accessors,
): result<expressionWithContext, errorValue> => { ): expressionWithContext => {
let blockCondition = ExpressionBuilder.eBlock(list{condition}) let blockCondition = ExpressionBuilder.eBlock(list{condition})
let rCondition = reduceExpression(blockCondition, bindings, accessors) let conditionValue = reduceExpression(blockCondition, bindings, accessors)
rCondition->Result.flatMap(conditionValue =>
switch conditionValue { switch conditionValue {
| InternalExpressionValue.IEvBool(false) => { | InternalExpressionValue.IEvBool(false) => {
let ifFalseBlock = eBlock(list{ifFalse}) let ifFalseBlock = eBlock(list{ifFalse})
ExpressionWithContext.withContext(ifFalseBlock, bindings)->Ok ExpressionWithContext.withContext(ifFalseBlock, bindings)
} }
| InternalExpressionValue.IEvBool(true) => { | InternalExpressionValue.IEvBool(true) => {
let ifTrueBlock = eBlock(list{ifTrue}) let ifTrueBlock = eBlock(list{ifTrue})
ExpressionWithContext.withContext(ifTrueBlock, bindings)->Ok ExpressionWithContext.withContext(ifTrueBlock, bindings)
} }
| _ => REExpectedType("Boolean", "")->Error | _ => REExpectedType("Boolean", "")->Reducer_ErrorValue.toException
} }
)
} }
let expandExpressionList = (aList, bindings: ExpressionT.bindings, accessors): result< let expandExpressionList = (
expressionWithContext, aList,
errorValue, bindings: ExpressionT.bindings,
> => accessors,
): expressionWithContext =>
switch aList { switch aList {
| list{ | list{
ExpressionT.EValue(IEvCall("$$_bindStatement_$$")), ExpressionT.EValue(IEvCall("$$_bindStatement_$$")),
@ -185,11 +179,11 @@ let dispatchMacroCall = (
doLambdaDefinition(bindings, parameters, lambdaDefinition) doLambdaDefinition(bindings, parameters, lambdaDefinition)
| list{ExpressionT.EValue(IEvCall("$$_ternary_$$")), condition, ifTrue, ifFalse} => | list{ExpressionT.EValue(IEvCall("$$_ternary_$$")), condition, ifTrue, ifFalse} =>
doTernary(condition, ifTrue, ifFalse, bindings, accessors) doTernary(condition, ifTrue, ifFalse, bindings, accessors)
| _ => ExpressionWithContext.noContext(ExpressionT.EList(aList))->Ok | _ => ExpressionWithContext.noContext(ExpressionT.EList(aList))
} }
switch macroExpression { switch macroExpression {
| EList(aList) => expandExpressionList(aList, bindings, accessors) | EList(aList) => expandExpressionList(aList, bindings, accessors)
| _ => ExpressionWithContext.noContext(macroExpression)->Ok | _ => ExpressionWithContext.noContext(macroExpression)
} }
} }

View File

@ -26,6 +26,8 @@ type errorValue =
type t = errorValue type t = errorValue
exception ErrorException(errorValue)
let errorToString = err => let errorToString = err =>
switch err { switch err {
| REArityError(_oFnName, arity, usedArity) => | REArityError(_oFnName, arity, usedArity) =>
@ -62,3 +64,20 @@ let errorToString = err =>
| RENeedToRun => "Need to run" | RENeedToRun => "Need to run"
| REOther(msg) => `Error: ${msg}` | REOther(msg) => `Error: ${msg}`
} }
let fromException = exn =>
switch exn {
| ErrorException(e) => e
| Js.Exn.Error(e) =>
switch Js.Exn.message(e) {
| Some(message) => REOther(message)
| None =>
switch Js.Exn.name(e) {
| Some(name) => REOther(name)
| None => REOther("Unknown error")
}
}
| _e => REOther("Unknown error")
}
let toException = (errorValue: t) => raise(ErrorException(errorValue))

View File

@ -21,10 +21,10 @@ let rec reduceExpressionInProject = (
expression: t, expression: t,
continuation: T.bindings, continuation: T.bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
): result<InternalExpressionValue.t, 'e> => { ): InternalExpressionValue.t => {
// Js.log(`reduce: ${T.toString(expression)} bindings: ${bindings->Bindings.toString}`) // Js.log(`reduce: ${T.toString(expression)} bindings: ${bindings->Bindings.toString}`)
switch expression { switch expression {
| T.EValue(value) => value->Ok | T.EValue(value) => value
| T.EList(list) => | T.EList(list) =>
switch list { switch list {
| list{EValue(IEvCall(fName)), ..._args} => | list{EValue(IEvCall(fName)), ..._args} =>
@ -41,20 +41,12 @@ and reduceExpressionList = (
expressions: list<t>, expressions: list<t>,
continuation: T.bindings, continuation: T.bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
): result<InternalExpressionValue.t, 'e> => { ): InternalExpressionValue.t => {
let racc: result< let acc: list<InternalExpressionValue.t> =
list<InternalExpressionValue.t>, expressions->Belt.List.reduceReverse(list{}, (acc, each: t) =>
'e, acc->Belt.List.add(each->reduceExpressionInProject(continuation, accessors))
> = expressions->Belt.List.reduceReverse(Ok(list{}), (racc, each: t) =>
racc->Result.flatMap(acc => {
each
->reduceExpressionInProject(continuation, accessors)
->Result.map(newNode => {
acc->Belt.List.add(newNode)
})
})
) )
racc->Result.flatMap(acc => acc->reduceValueList(accessors)) acc->reduceValueList(accessors)
} }
/* /*
@ -63,48 +55,34 @@ and reduceExpressionList = (
and reduceValueList = ( and reduceValueList = (
valueList: list<InternalExpressionValue.t>, valueList: list<InternalExpressionValue.t>,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
): result<InternalExpressionValue.t, 'e> => ): InternalExpressionValue.t =>
switch valueList { switch valueList {
| list{IEvCall(fName), ...args} => { | list{IEvCall(fName), ...args} => {
let rCheckedArgs = switch fName { let checkedArgs = switch fName {
| "$_setBindings_$" | "$_setTypeOfBindings_$" | "$_setTypeAliasBindings_$" => args->Ok | "$_setBindings_$" | "$_setTypeOfBindings_$" | "$_setTypeAliasBindings_$" => args
| _ => args->Lambda.checkIfReduced | _ => args->Lambda.checkIfReduced
} }
rCheckedArgs->Result.flatMap(checkedArgs =>
(fName, checkedArgs->Belt.List.toArray)->BuiltIn.dispatch( (fName, checkedArgs->Belt.List.toArray)->BuiltIn.dispatch(
accessors, accessors,
reduceExpressionInProject, reduceExpressionInProject,
) )
)
} }
| list{IEvLambda(_)} => | list{IEvLambda(_)} =>
// TODO: remove on solving issue#558 // TODO: remove on solving issue#558
valueList valueList->Lambda.checkIfReduced->Belt.List.toArray->InternalExpressionValue.IEvArray
->Lambda.checkIfReduced
->Result.flatMap(reducedValueList =>
reducedValueList->Belt.List.toArray->InternalExpressionValue.IEvArray->Ok
)
| list{IEvLambda(lambdaCall), ...args} => | list{IEvLambda(lambdaCall), ...args} =>
args args
->Lambda.checkIfReduced ->Lambda.checkIfReduced
->Result.flatMap(checkedArgs => ->Lambda.doLambdaCall(lambdaCall, _, accessors, reduceExpressionInProject)
Lambda.doLambdaCall(lambdaCall, checkedArgs, accessors, reduceExpressionInProject) | _ => valueList->Lambda.checkIfReduced->Belt.List.toArray->InternalExpressionValue.IEvArray
)
| _ =>
valueList
->Lambda.checkIfReduced
->Result.flatMap(reducedValueList =>
reducedValueList->Belt.List.toArray->InternalExpressionValue.IEvArray->Ok
)
} }
let reduceReturningBindings = ( let reduceReturningBindings = (
expression: t, expression: t,
continuation: T.bindings, continuation: T.bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
): (result<InternalExpressionValue.t, 'e>, T.bindings) => { ): (InternalExpressionValue.t, T.bindings) => {
let states = accessors.states let states = accessors.states
let result = reduceExpressionInProject(expression, continuation, accessors) let result = reduceExpressionInProject(expression, continuation, accessors)
(result, states.continuation) (result, states.continuation)
@ -118,7 +96,11 @@ module BackCompatible = {
let evaluate = (expression: t): result<InternalExpressionValue.t, errorValue> => { let evaluate = (expression: t): result<InternalExpressionValue.t, errorValue> => {
let accessors = ProjectAccessorsT.identityAccessors let accessors = ProjectAccessorsT.identityAccessors
expression->reduceExpressionInProject(accessors.stdLib, accessors) try {
expression->reduceExpressionInProject(accessors.stdLib, accessors)->Ok
} catch {
| exn => Reducer_ErrorValue.fromException(exn)->Error
}
} }
let evaluateString = (peggyCode: string): result<InternalExpressionValue.t, errorValue> => let evaluateString = (peggyCode: string): result<InternalExpressionValue.t, errorValue> =>

View File

@ -18,12 +18,14 @@ type expressionWithContext =
| ExpressionWithContext(expression, context) | ExpressionWithContext(expression, context)
| ExpressionNoContext(expression) | ExpressionNoContext(expression)
type t = expressionWithContext
let callReducer = ( let callReducer = (
expressionWithContext: expressionWithContext, expressionWithContext: expressionWithContext,
bindings: bindings, bindings: bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
): result<internalExpressionValue, errorValue> => { ): internalExpressionValue => {
switch expressionWithContext { switch expressionWithContext {
| ExpressionNoContext(expr) => | ExpressionNoContext(expr) =>
// Js.log(`callReducer: bindings ${Bindings.toString(bindings)} expr ${ExpressionT.toString(expr)}`) // Js.log(`callReducer: bindings ${Bindings.toString(bindings)} expr ${ExpressionT.toString(expr)}`)
@ -51,3 +53,10 @@ let toStringResult = rExpressionWithContext =>
| Ok(expressionWithContext) => `Ok(${toString(expressionWithContext)})` | Ok(expressionWithContext) => `Ok(${toString(expressionWithContext)})`
| Error(errorValue) => ErrorValue.errorToString(errorValue) | Error(errorValue) => ErrorValue.errorToString(errorValue)
} }
let resultToValue = (rExpressionWithContext: result<t, errorValue>): t => {
switch rExpressionWithContext {
| Ok(expressionWithContext) => expressionWithContext
| Error(errorValue) => ErrorValue.toException(errorValue)
}
}

View File

@ -1,7 +1,6 @@
module ErrorValue = Reducer_ErrorValue module ErrorValue = Reducer_ErrorValue
module ExpressionT = Reducer_Expression_T module ExpressionT = Reducer_Expression_T
module InternalExpressionValue = ReducerInterface_InternalExpressionValue module InternalExpressionValue = ReducerInterface_InternalExpressionValue
module Result = Belt.Result
module Bindings = Reducer_Bindings module Bindings = Reducer_Bindings
type errorValue = Reducer_ErrorValue.errorValue type errorValue = Reducer_ErrorValue.errorValue
@ -10,19 +9,15 @@ type internalExpressionValue = InternalExpressionValue.t
let isMacroName = (fName: string): bool => fName->Js.String2.startsWith("$$") let isMacroName = (fName: string): bool => fName->Js.String2.startsWith("$$")
let rec replaceSymbols = (bindings: ExpressionT.bindings, expression: expression): result< let rec replaceSymbols = (bindings: ExpressionT.bindings, expression: expression): expression =>
expression,
errorValue,
> =>
switch expression { switch expression {
| ExpressionT.EValue(value) => | ExpressionT.EValue(value) => replaceSymbolOnValue(bindings, value)->ExpressionT.EValue
replaceSymbolOnValue(bindings, value)->Result.map(evValue => evValue->ExpressionT.EValue)
| ExpressionT.EList(list) => | ExpressionT.EList(list) =>
switch list { switch list {
| list{EValue(IEvCall(fName)), ..._args} => | list{EValue(IEvCall(fName)), ..._args} =>
switch isMacroName(fName) { switch isMacroName(fName) {
// A macro reduces itself so we dont dive in it // A macro reduces itself so we dont dive in it
| true => expression->Ok | true => expression
| false => replaceSymbolsOnExpressionList(bindings, list) | false => replaceSymbolsOnExpressionList(bindings, list)
} }
| _ => replaceSymbolsOnExpressionList(bindings, list) | _ => replaceSymbolsOnExpressionList(bindings, list)
@ -30,23 +25,21 @@ let rec replaceSymbols = (bindings: ExpressionT.bindings, expression: expression
} }
and replaceSymbolsOnExpressionList = (bindings, list) => { and replaceSymbolsOnExpressionList = (bindings, list) => {
let racc = list->Belt.List.reduceReverse(Ok(list{}), (racc, each: expression) => let racc =
racc->Result.flatMap(acc => { list->Belt.List.reduceReverse(list{}, (acc, each: expression) =>
replaceSymbols(bindings, each)->Result.flatMap(newNode => { replaceSymbols(bindings, each)->Belt.List.add(acc, _)
acc->Belt.List.add(newNode)->Ok
})
})
) )
racc->Result.map(acc => acc->ExpressionT.EList) ExpressionT.EList(racc)
} }
and replaceSymbolOnValue = (bindings, evValue: internalExpressionValue) => and replaceSymbolOnValue = (bindings, evValue: internalExpressionValue) =>
switch evValue { switch evValue {
| IEvSymbol(symbol) => Bindings.getWithDefault(bindings, symbol, evValue)->Ok | IEvSymbol(symbol) => Bindings.getWithDefault(bindings, symbol, evValue)
| IEvCall(symbol) => Bindings.getWithDefault(bindings, symbol, evValue)->checkIfCallable | IEvCall(symbol) => Bindings.getWithDefault(bindings, symbol, evValue)->checkIfCallable
| _ => evValue->Ok | _ => evValue
} }
and checkIfCallable = (evValue: internalExpressionValue) => and checkIfCallable = (evValue: internalExpressionValue) =>
switch evValue { switch evValue {
| IEvCall(_) | IEvLambda(_) => evValue->Ok | IEvCall(_) | IEvLambda(_) => evValue
| _ => ErrorValue.RENotAFunction(InternalExpressionValue.toString(evValue))->Error | _ =>
ErrorValue.RENotAFunction(InternalExpressionValue.toString(evValue))->ErrorValue.toException
} }

View File

@ -23,27 +23,25 @@ let checkArity = (
let argsLength = Belt.List.length(args) let argsLength = Belt.List.length(args)
let parametersLength = Js.Array2.length(lambdaValue.parameters) let parametersLength = Js.Array2.length(lambdaValue.parameters)
if argsLength !== parametersLength { if argsLength !== parametersLength {
ErrorValue.REArityError(None, parametersLength, argsLength)->Error ErrorValue.REArityError(None, parametersLength, argsLength)->ErrorValue.toException
} else { } else {
args->Ok args
} }
} }
let exprOrFFI = castInternalCodeToExpression(lambdaValue.body) let exprOrFFI = castInternalCodeToExpression(lambdaValue.body)
switch exprOrFFI { switch exprOrFFI {
| NotFFI(_) => reallyCheck | NotFFI(_) => reallyCheck
| FFI(_) => args->Ok | FFI(_) => args
} }
} }
let checkIfReduced = (args: list<internalExpressionValue>) => let checkIfReduced = (args: list<internalExpressionValue>) =>
args->Belt.List.reduceReverse(Ok(list{}), (rAcc, arg) => args->Belt.List.reduceReverse(list{}, (acc, arg) =>
rAcc->Result.flatMap(acc =>
switch arg { switch arg {
| IEvSymbol(symbol) => ErrorValue.RESymbolNotFound(symbol)->Error | IEvSymbol(symbol) => ErrorValue.RESymbolNotFound(symbol)->ErrorValue.toException
| _ => list{arg, ...acc}->Ok | _ => list{arg, ...acc}
} }
) )
)
let caseNotFFI = ( let caseNotFFI = (
lambdaValue: ExpressionValue.lambdaValue, lambdaValue: ExpressionValue.lambdaValue,
@ -63,7 +61,10 @@ let caseNotFFI = (
} }
let caseFFI = (ffiFn: ExpressionT.ffiFn, args, accessors: ProjectAccessorsT.t) => { let caseFFI = (ffiFn: ExpressionT.ffiFn, args, accessors: ProjectAccessorsT.t) => {
ffiFn(args->Belt.List.toArray, accessors.environment) switch ffiFn(args->Belt.List.toArray, accessors.environment) {
| Ok(value) => value
| Error(value) => value->ErrorValue.toException
}
} }
let applyParametersToLambda = ( let applyParametersToLambda = (
@ -71,16 +72,13 @@ let applyParametersToLambda = (
args, args,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
): result<internalExpressionValue, 'e> => { ): internalExpressionValue => {
checkArity(lambdaValue, args)->Result.flatMap(args => let args = checkArity(lambdaValue, args)->checkIfReduced
checkIfReduced(args)->Result.flatMap(args => {
let exprOrFFI = castInternalCodeToExpression(lambdaValue.body) let exprOrFFI = castInternalCodeToExpression(lambdaValue.body)
switch exprOrFFI { switch exprOrFFI {
| NotFFI(expr) => caseNotFFI(lambdaValue, expr, args, accessors, reducer) | NotFFI(expr) => caseNotFFI(lambdaValue, expr, args, accessors, reducer)
| FFI(ffiFn) => caseFFI(ffiFn, args, accessors) | FFI(ffiFn) => caseFFI(ffiFn, args, accessors)
} }
})
)
} }
let doLambdaCall = ( let doLambdaCall = (
@ -95,7 +93,7 @@ let foreignFunctionInterface = (
argArray: array<internalExpressionValue>, argArray: array<internalExpressionValue>,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reducer: ProjectReducerFnT.t, reducer: ProjectReducerFnT.t,
): result<internalExpressionValue, Reducer_ErrorValue.errorValue> => { ): internalExpressionValue => {
let args = argArray->Belt.List.fromArray let args = argArray->Belt.List.fromArray
applyParametersToLambda(lambdaValue, args, accessors, reducer) applyParametersToLambda(lambdaValue, args, accessors, reducer)
} }

View File

@ -10,32 +10,34 @@ type expression = ExpressionT.expression
type internalExpressionValue = InternalExpressionValue.t type internalExpressionValue = InternalExpressionValue.t
type expressionWithContext = ExpressionWithContext.expressionWithContext type expressionWithContext = ExpressionWithContext.expressionWithContext
let expandMacroCall = ( let expandMacroCallRs = (
macroExpression: expression, macroExpression: expression,
bindings: ExpressionT.bindings, bindings: ExpressionT.bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reduceExpression: ProjectReducerFnT.t, reduceExpression: ProjectReducerFnT.t,
): result<expressionWithContext, 'e> => ): result<expressionWithContext, 'e> =>
try {
Reducer_Dispatch_BuiltInMacros.dispatchMacroCall( Reducer_Dispatch_BuiltInMacros.dispatchMacroCall(
macroExpression, macroExpression,
bindings, bindings,
accessors, accessors,
reduceExpression, reduceExpression,
) )->Ok
} catch {
| exn => Reducer_ErrorValue.fromException(exn)->Error
}
let doMacroCall = ( let doMacroCall = (
macroExpression: expression, macroExpression: expression,
bindings: ExpressionT.bindings, bindings: ExpressionT.bindings,
accessors: ProjectAccessorsT.t, accessors: ProjectAccessorsT.t,
reduceExpression: ProjectReducerFnT.t, reduceExpression: ProjectReducerFnT.t,
): result<internalExpressionValue, 'e> => ): internalExpressionValue =>
expandMacroCall( Reducer_Dispatch_BuiltInMacros.dispatchMacroCall(
macroExpression, macroExpression,
bindings, bindings,
(accessors: ProjectAccessorsT.t), (accessors: ProjectAccessorsT.t),
(reduceExpression: ProjectReducerFnT.t), (reduceExpression: ProjectReducerFnT.t),
)->Result.flatMap(expressionWithContext => )->ExpressionWithContext.callReducer(bindings, accessors, reduceExpression)
ExpressionWithContext.callReducer(expressionWithContext, bindings, accessors, reduceExpression)
)
let isMacroName = (fName: string): bool => fName->Js.String2.startsWith("$$") let isMacroName = (fName: string): bool => fName->Js.String2.startsWith("$$")

View File

@ -82,3 +82,9 @@ type optionFfiFnReturningResult = (
type expressionOrFFI = type expressionOrFFI =
| NotFFI(expression) | NotFFI(expression)
| FFI(ffiFn) | FFI(ffiFn)
let resultToValue = (rExpression: result<t, Reducer_ErrorValue.t>): t =>
switch rExpression {
| Ok(expression) => expression
| Error(errorValue) => Reducer_ErrorValue.toException(errorValue)
}

View File

@ -15,17 +15,13 @@ let ievFromTypeExpression = (
let sourceCode = `type ${sIndex}=${typeExpressionSourceCode}` let sourceCode = `type ${sIndex}=${typeExpressionSourceCode}`
Reducer_Expression.BackCompatible.parse(sourceCode)->Belt.Result.flatMap(expr => { Reducer_Expression.BackCompatible.parse(sourceCode)->Belt.Result.flatMap(expr => {
let accessors = ProjectAccessorsT.identityAccessors let accessors = ProjectAccessorsT.identityAccessors
let result = reducerFn(expr, Bindings.emptyBindings, accessors) let _result = reducerFn(expr, Bindings.emptyBindings, accessors)
let nameSpace = accessors.states.continuation let nameSpace = accessors.states.continuation
switch result {
| Ok(_) =>
switch Bindings.getType(nameSpace, sIndex) { switch Bindings.getType(nameSpace, sIndex) {
| Some(value) => value->Ok | Some(value) => value->Ok
| None => raise(Reducer_Exception.ImpossibleException("Reducer_Type_Compile-none")) | None => raise(Reducer_Exception.ImpossibleException("Reducer_Type_Compile-none"))
} }
| err => err
}
}) })
} }

View File

@ -244,3 +244,9 @@ let nameSpaceGet = (nameSpace: nameSpace, key: string): option<t> => {
let NameSpace(container) = nameSpace let NameSpace(container) = nameSpace
container->Belt.Map.String.get(key) container->Belt.Map.String.get(key)
} }
let resultToValue = (rExpression: result<t, Reducer_ErrorValue.t>): t =>
switch rExpression {
| Ok(expression) => expression
| Error(errorValue) => Reducer_ErrorValue.toException(errorValue)
}

View File

@ -183,17 +183,6 @@ let buildExpression = (this: t): t => {
} }
} }
let wrappedReducer = (
rExpression: T.expressionArgumentType,
aContinuation: T.continuation,
accessors: ProjectAccessorsT.t,
): T.resultArgumentType => {
Belt.Result.flatMap(
rExpression,
Reducer_Expression.reduceExpressionInProject(_, aContinuation, accessors),
)
}
let doBuildResult = ( let doBuildResult = (
this: t, this: t,
aContinuation: T.continuation, aContinuation: T.continuation,
@ -202,9 +191,12 @@ let doBuildResult = (
this this
->getExpression ->getExpression
->Belt.Option.map( ->Belt.Option.map(
Belt.Result.flatMap( Belt.Result.flatMap(_, expression =>
_, try {
Reducer_Expression.reduceExpressionInProject(_, aContinuation, accessors), Reducer_Expression.reduceExpressionInProject(expression, aContinuation, accessors)->Ok
} catch {
| exn => Reducer_ErrorValue.fromException(exn)->Error
}
), ),
) )

View File

@ -2,8 +2,4 @@ module ExpressionT = Reducer_Expression_T
module InternalExpressionValue = ReducerInterface_InternalExpressionValue module InternalExpressionValue = ReducerInterface_InternalExpressionValue
module ProjectAccessorsT = ReducerProject_ProjectAccessors_T module ProjectAccessorsT = ReducerProject_ProjectAccessors_T
type t = ( type t = (ExpressionT.t, ExpressionT.bindings, ProjectAccessorsT.t) => InternalExpressionValue.t
ExpressionT.t,
ExpressionT.bindings,
ProjectAccessorsT.t,
) => result<InternalExpressionValue.t, Reducer_ErrorValue.errorValue>