diff --git a/examples/src/LoginForm.re b/examples/src/LoginForm.re index e2c9dbdc..2980768e 100644 --- a/examples/src/LoginForm.re +++ b/examples/src/LoginForm.re @@ -4,18 +4,9 @@ module LoginForm = [%form password: string, rememberMe: bool, }; - type output = input -]; - -let initialInput: LoginForm.input = { - email: "", - password: "", - rememberMe: false, -}; - -let validators: LoginForm.validators = { - email: - Some({ + type output = input; + let validators = { + email: { strategy: OnFirstSuccessOrFirstBlur, validate: ({email}) => { let emailRegex = [%bs.re {|/.*@.*\..+/|}]; @@ -26,17 +17,23 @@ let validators: LoginForm.validators = { | _ => Ok(email) }; }, - }), - password: - Some({ + }, + password: { strategy: OnFirstBlur, validate: ({password}) => switch (password) { | "" => Error("Password is required") | _ => Ok(password) }, - }), - rememberMe: None, + }, + rememberMe: None, + } +]; + +let initialInput: LoginForm.input = { + email: "", + password: "", + rememberMe: false, }; [@react.component] @@ -44,7 +41,6 @@ let make = () => { let form = LoginForm.useForm( ~initialInput, - ~validators, ~onSubmit=(output, form) => { Js.log2("Submitted with:", output); Js.Global.setTimeout( diff --git a/examples/src/SignupForm.re b/examples/src/SignupForm.re index 73562359..4ecc0799 100644 --- a/examples/src/SignupForm.re +++ b/examples/src/SignupForm.re @@ -4,18 +4,9 @@ module SignupForm = [%form password: [@field.deps passwordConfirmation] string, passwordConfirmation: string, }; - type output = input -]; - -let initialInput: SignupForm.input = { - email: "", - password: "", - passwordConfirmation: "", -}; - -let validators: SignupForm.validators = { - email: - Some({ + type output = input; + let validators = { + email: { strategy: OnFirstSuccessOrFirstBlur, validate: ({email}) => { let emailRegex = [%bs.re {|/.*@.*\..+/|}]; @@ -26,9 +17,8 @@ let validators: SignupForm.validators = { | _ => Ok(email) }; }, - }), - password: - Some({ + }, + password: { strategy: OnFirstSuccessOrFirstBlur, validate: ({password}) => { let minLength = 4; @@ -39,9 +29,8 @@ let validators: SignupForm.validators = { | _ => Ok(password) }; }, - }), - passwordConfirmation: - Some({ + }, + passwordConfirmation: { strategy: OnFirstSuccessOrFirstBlur, validate: ({password, passwordConfirmation}) => switch (passwordConfirmation) { @@ -50,7 +39,14 @@ let validators: SignupForm.validators = { Error("Password doesn't match") | _ => Ok(passwordConfirmation) }, - }), + }, + } +]; + +let initialInput: SignupForm.input = { + email: "", + password: "", + passwordConfirmation: "", }; [@react.component] @@ -58,7 +54,6 @@ let make = () => { let form = SignupForm.useForm( ~initialInput, - ~validators, ~onSubmit=(output, form) => { Js.log2("Submitted with:", output); Js.Global.setTimeout( diff --git a/lib/ppx/AstHelpers.re b/lib/ppx/AstHelpers.re index 05d01081..7d391ee7 100644 --- a/lib/ppx/AstHelpers.re +++ b/lib/ppx/AstHelpers.re @@ -19,20 +19,28 @@ module T = { ( ~name, ~loc, - ~typ: FieldSpec.t => core_type, - fields: list(FieldSpec.t), + ~typ: + (~validator: FieldValidator.t, ~output_type: FieldType.t) => + core_type, + scheme: Scheme.t, ) => name |> str(~loc) |> Type.mk( ~kind= Ptype_record( - fields - |> List.map((field: FieldSpec.t) => - Type.field( - field.id |> Field.to_string |> str(~loc), - field |> typ, - ) + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field(field) => + Type.field( + field.name |> str(~loc), + typ( + ~validator=field.validator, + ~output_type=field.output_type, + ), + ) + } ), ), ) @@ -64,7 +72,9 @@ module E = { let field = (~of_ as record, ~loc, field: Field.t) => Exp.field( Exp.ident(Lident(record) |> lid(~loc)), - Lident(field |> Field.to_string) |> lid(~loc), + switch (field) { + | Field(field) => Lident(field) |> lid(~loc) + }, ); let field2 = (~of_ as (record1, record2), ~loc, field: Field.t) => @@ -73,25 +83,62 @@ module E = { Exp.ident(Lident(record1) |> lid(~loc)), Lident(record2) |> lid(~loc), ), - Lident(field |> Field.to_string) |> lid(~loc), + switch (field) { + | Field(field) => Lident(field) |> lid(~loc) + }, ); let ref_field = (~of_ as record, ~loc, field: Field.t) => Exp.field( record |> ref_(~loc), - Lident(field |> Field.to_string) |> lid(~loc), + switch (field) { + | Field(field) => Lident(field) |> lid(~loc) + }, ); let update_field = (~of_ as record, ~with_ as value, ~loc, field: Field.t) => Exp.record( - [(Lident(field |> Field.to_string) |> lid(~loc), value)], + [ + ( + switch (field) { + | Field(field) => Lident(field) |> lid(~loc) + }, + value, + ), + ], Some(Exp.ident(Lident(record) |> lid(~loc))), ); + let update_field2 = + (~of_ as (record1, record2), ~with_ as value, ~loc, field: Field.t) => + Exp.record( + [ + ( + switch (field) { + | Field(field) => Lident(field) |> lid(~loc) + }, + value, + ), + ], + Some( + Exp.field( + Exp.ident(Lident(record1) |> lid(~loc)), + Lident(record2) |> lid(~loc), + ), + ), + ); + let update_ref_field = (~of_ as record, ~with_ as value, ~loc, field: Field.t) => Exp.record( - [(Lident(field |> Field.to_string) |> lid(~loc), value)], + [ + ( + switch (field) { + | Field(field) => Lident(field) |> lid(~loc) + }, + value, + ), + ], Some(record |> ref_(~loc)), ); diff --git a/lib/ppx/Form.re b/lib/ppx/Form.re index e429ec66..82c0246a 100644 --- a/lib/ppx/Form.re +++ b/lib/ppx/Form.re @@ -5,982 +5,6 @@ open AstHelpers; open Ppxlib; open Ast_helper; -let open_formality = (~loc) => [%stri open Formality]; - -let input_type = (input_type: InputType.t) => { - input_type |> InputType.structure_item; -}; - -let output_type = (output_type: OutputType.t) => { - output_type |> OutputType.structure_item; -}; - -let message_type = (message_type: MessageType.t) => - message_type |> MessageType.structure_item; - -let submission_error_type = (submission_error_type: SubmissionErrorType.t) => - submission_error_type |> SubmissionErrorType.structure_item; - -let validators_type = (~loc, fields: list(FieldSpec.t)) => { - fields - |> T.record_of_fields( - ~name="validators", - ~loc, - ~typ=field => { - let typ = - Typ.constr( - Lident("singleValueValidator") |> lid(~loc), - [ - Typ.constr(Lident("input") |> lid(~loc), []), - field.output_type |> FieldType.unpack, - Typ.constr(Lident("message") |> lid(~loc), []), - ], - ); - switch (field.validator) { - | `Required => typ - | `Optional => Typ.constr(Lident("option") |> lid(~loc), [typ]) - }; - }, - ); -}; - -let fields_statuses_type = (~loc, fields: list(FieldSpec.t)) => { - fields - |> T.record_of_fields(~name="fieldsStatuses", ~loc, ~typ=field => - Typ.constr( - Lident("fieldStatus") |> lid(~loc), - [ - field.output_type |> FieldType.unpack, - Typ.constr(Lident("message") |> lid(~loc), []), - ], - ) - ); -}; - -let state_type = (~loc) => [%stri - type state = { - input, - fieldsStatuses, - formStatus: formStatus(submissionError), - submissionStatus, - } -]; - -let action_type = (~loc, fields: list(FieldSpec.t)) => { - let update_actions = - fields - |> List.map((field: FieldSpec.t) => - field.id - |> Field.update_action - |> T.constructor(~args=[[%type: input]], ~loc) - ); - let blur_actions = - fields - |> List.map((field: FieldSpec.t) => - field.id |> Field.blur_action |> T.constructor(~loc) - ); - let rest_actions = [ - "Submit" |> T.constructor(~loc), - "SetSubmittedStatus" - |> T.constructor(~args=[[%type: option(input)]], ~loc), - "SetSubmissionFailedStatus" - |> T.constructor(~args=[[%type: submissionError]], ~loc), - "MapSubmissionError" - |> T.constructor( - ~args=[[%type: submissionError => submissionError]], - ~loc, - ), - "DismissSubmissionError" |> T.constructor(~loc), - "DismissSubmissionResult" |> T.constructor(~loc), - "Reset" |> T.constructor(~loc), - ]; - - "action" - |> str(~loc) - |> Type.mk( - ~kind= - Ptype_variant( - rest_actions - |> List.append(blur_actions) - |> List.append(update_actions), - ), - ) - |> StructureItem.from_type_declaration(~loc, ~rec_flag=Recursive); -}; - -let interface_type = (~loc, fields: list(FieldSpec.t)) => { - let f = (x, t) => t |> Type.field(x |> str(~loc)); - - let base = [ - f("input", [%type: input]), - f("status", [%type: formStatus(submissionError)]), - f("dirty", [%type: unit => bool]), - f("valid", [%type: unit => bool]), - f("submitting", [%type: bool]), - f("submit", [%type: unit => unit]), - f("dismissSubmissionError", [%type: unit => unit]), - f("dismissSubmissionResult", [%type: unit => unit]), - f( - "mapSubmissionError", - [%type: (submissionError => submissionError) => unit], - ), - f("reset", [%type: unit => unit]), - ]; - - let update_fns = - fields - |> List.map((field: FieldSpec.t) => { - f(field.id |> Field.update_fn, [%type: input => unit]) - }); - - let blur_fns = - fields - |> List.map((field: FieldSpec.t) => { - f(field.id |> Field.blur_fn, [%type: unit => unit]) - }); - - let result_fns = - fields - |> List.map((field: FieldSpec.t) => { - f( - field.id |> Field.result_fn, - [%type: - unit => - option( - result([%t field.output_type |> FieldType.unpack], message), - ) - ], - ) - }); - - "interface" - |> str(~loc) - |> Type.mk( - ~kind= - Ptype_record( - base - |> List.append(result_fns) - |> List.append(blur_fns) - |> List.append(update_fns), - ), - ) - |> StructureItem.from_type_declaration(~loc, ~rec_flag=Recursive); -}; - -let initial_fields_statuses_fn = (~loc, fields: list(FieldSpec.t)) => { - [%stri - let initialFieldsStatuses = (_input: input) => [%e - Exp.record( - fields - |> List.map((field: FieldSpec.t) => - ( - Lident(field.id |> Field.to_string) |> lid(~loc), - [%expr Pristine], - ) - ), - None, - ) - ] - ]; -}; - -let initial_state_fn = (~loc) => [%stri - let initialState = input => { - input, - fieldsStatuses: input->initialFieldsStatuses, - formStatus: Editing, - submissionStatus: NeverSubmitted, - } -]; - -let validate_form_fn = (~loc, fields: list(FieldSpec.t)) => { - let field_result = x => (x |> Field.to_string) ++ "Result"; - let field_result_visibility = x => - (x |> Field.to_string) ++ "ResultVisibility"; - - [%stri - let validateForm = - (input: input, ~validators: validators) - : formValidationResult(output, fieldsStatuses) => [%e - Exp.match( - Exp.tuple( - fields - |> List.map((field: FieldSpec.t) => - switch (field.validator) { - | `Required => - %expr - { - let validator = [%e - field.id |> E.field(~of_="validators", ~loc) - ]; - (validator.validate(input), Shown); - } - | `Optional => - switch%expr ( - [%e field.id |> E.field(~of_="validators", ~loc)] - ) { - | Some(validator) => (validator.validate(input), Shown) - | None => ( - Ok([%e field.id |> E.field(~of_="input", ~loc)]), - Hidden, - ) - } - } - ), - ), - [ - // ((Ok(value), visibility), ...) => Ok(...) - Exp.case( - Pat.tuple( - fields - |> List.map((field: FieldSpec.t) => - Pat.tuple([ - Pat.alias( - Pat.construct( - ~attrs=[explicit_arity(~loc)], - Lident("Ok") |> lid(~loc), - Some( - Pat.tuple([ - Pat.var( - field.id |> Field.to_string |> str(~loc), - ), - ]), - ), - ), - field.id |> field_result |> str(~loc), - ), - Pat.var( - field.id |> field_result_visibility |> str(~loc), - ), - ]) - ), - ), - [%expr - Ok({ - output: [%e - Exp.record( - fields - |> List.map((field: FieldSpec.t) => - ( - Lident(field.id |> Field.to_string) |> lid(~loc), - Exp.ident( - Lident(field.id |> Field.to_string) |> lid(~loc), - ), - ) - ), - None, - ) - ], - fieldsStatuses: [%e - Exp.record( - fields - |> List.map((field: FieldSpec.t) => - ( - Lident(field.id |> Field.to_string) |> lid(~loc), - [%expr - Dirty( - [%e - Exp.ident( - Lident(field.id |> field_result) - |> lid(~loc), - ) - ], - [%e - Exp.ident( - Lident(field.id |> field_result_visibility) - |> lid(~loc), - ) - ], - ) - ], - ) - ), - None, - ) - ], - }) - ], - ), - // ((_, visibility), ...) => Error(...) - Exp.case( - Pat.tuple( - fields - |> List.map((field: FieldSpec.t) => - Pat.tuple([ - Pat.var(field.id |> field_result |> str(~loc)), - Pat.var( - field.id |> field_result_visibility |> str(~loc), - ), - ]) - ), - ), - [%expr - Error({ - fieldsStatuses: [%e - Exp.record( - fields - |> List.map((field: FieldSpec.t) => - ( - Lident(field.id |> Field.to_string) |> lid(~loc), - [%expr - Dirty( - [%e - Exp.ident( - Lident(field.id |> field_result) - |> lid(~loc), - ) - ], - [%e - Exp.ident( - Lident(field.id |> field_result_visibility) - |> lid(~loc), - ) - ], - ) - ], - ) - ), - None, - ) - ], - }) - ], - ), - ], - ) - ] - ]; -}; - -let use_form_fn = (~loc, fields: list(FieldSpec.t)) => [%stri - let useForm = - ( - ~initialInput: input, - ~validators: validators, - ~onSubmit: - (output, submissionCallbacks(input, submissionError)) => unit, - ) => { - // Reducer - let memoizedInitialState = - React.useMemo1(() => initialInput->initialState, [|initialInput|]); - - let (state, dispatch) = - memoizedInitialState->ReactUpdate.useReducer((state, action) => { - %e - { - let update_actions = - fields - |> List.map((field: FieldSpec.t) => - Exp.case( - Pat.construct( - ~attrs=[explicit_arity(~loc)], - Lident(field.id |> Field.update_action) |> lid(~loc), - Some(Pat.tuple([Pat.var("input" |> str(~loc))])), - ), - switch (field.deps) { - | [] => - %expr - { - let {fieldsStatuses, submissionStatus} = state; - Update({ - ...state, - input, - fieldsStatuses: - switch%e (field.validator) { - | `Required => - %expr - { - validateFieldOnChangeWithValidator( - ~input, - ~fieldStatus=[%e - field.id - |> E.field(~of_="fieldsStatuses", ~loc) - ], - ~submissionStatus, - ~validator=[%e - field.id - |> E.field(~of_="validators", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ); - } - | `Optional => - switch%expr ( - [%e - field.id |> E.field(~of_="validators", ~loc) - ] - ) { - | Some(validator) => - validateFieldOnChangeWithValidator( - ~input, - ~fieldStatus=[%e - field.id - |> E.field(~of_="fieldsStatuses", ~loc) - ], - ~submissionStatus, - ~validator, - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - | None => - validateFieldOnChangeWithoutValidator( - ~fieldInput=[%e - field.id |> E.field(~of_="input", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - } - }, - }); - } - | [dep, ...deps] => - %expr - { - let fieldsStatuses = ref(state.fieldsStatuses); - let {submissionStatus} = state; - - %e - { - let validate_dep = dep => { - let field = - fields - |> List.find((field: FieldSpec.t) => - field.id |> Field.eq(dep) - ); - switch (field.validator) { - | `Required => - switch%expr ( - validateFieldDependencyOnChange( - ~input, - ~fieldStatus=[%e - field.id - |> E.ref_field(~of_="fieldsStatuses", ~loc) - ], - ~validator=[%e - field.id - |> E.field(~of_="validators", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_ref_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - ) { - | Some(result) => fieldsStatuses := result - | None => () - } - | `Optional => - switch%expr ( - [%e - field.id |> E.field(~of_="validators", ~loc) - ] - ) { - | None => () - | Some(validator) => - switch ( - validateFieldDependencyOnChange( - ~input, - ~fieldStatus=[%e - field.id - |> E.ref_field( - ~of_="fieldsStatuses", - ~loc, - ) - ], - ~validator, - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_ref_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - ) { - | Some(result) => fieldsStatuses := result - | None => () - } - } - }; - }; - deps - |> E.seq( - ~exp=dep |> validate_dep, - ~make=validate_dep, - ); - }; - - Update({ - ...state, - input, - fieldsStatuses: - switch%e (field.validator) { - | `Required => - %expr - { - validateFieldOnChangeWithValidator( - ~input, - ~fieldStatus=[%e - field.id - |> E.ref_field(~of_="fieldsStatuses", ~loc) - ], - ~submissionStatus, - ~validator=[%e - field.id - |> E.field(~of_="validators", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_ref_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ); - } - | `Optional => - switch%expr ( - [%e - field.id |> E.field(~of_="validators", ~loc) - ] - ) { - | Some(validator) => - validateFieldOnChangeWithValidator( - ~input, - ~fieldStatus=[%e - field.id - |> E.ref_field(~of_="fieldsStatuses", ~loc) - ], - ~submissionStatus, - ~validator, - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_ref_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - | None => - validateFieldOnChangeWithoutValidator( - ~fieldInput=[%e - field.id |> E.field(~of_="input", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_ref_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - } - }, - }); - } - }, - ) - ); - - let blur_actions = - fields - |> List.map((field: FieldSpec.t) => - Exp.case( - Pat.construct( - Lident(field.id |> Field.blur_action) |> lid(~loc), - None, - ), - { - %expr - { - let {input, fieldsStatuses} = state; - let result = - switch%e (field.validator) { - | `Required => - %expr - validateFieldOnBlurWithValidator( - ~input, - ~fieldStatus=[%e - field.id - |> E.field(~of_="fieldsStatuses", ~loc) - ], - ~validator=[%e - field.id |> E.field(~of_="validators", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - | `Optional => - switch%expr ( - [%e field.id |> E.field(~of_="validators", ~loc)] - ) { - | Some(validator) => - validateFieldOnBlurWithValidator( - ~input, - ~fieldStatus=[%e - field.id - |> E.field(~of_="fieldsStatuses", ~loc) - ], - ~validator, - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - | None => - validateFieldOnBlurWithoutValidator( - ~fieldInput=[%e - field.id |> E.field(~of_="input", ~loc) - ], - ~fieldStatus=[%e - field.id - |> E.field(~of_="fieldsStatuses", ~loc) - ], - ~setStatus=[%e - [%expr - status => [%e - field.id - |> E.update_field( - ~of_="fieldsStatuses", - ~with_=[%expr status], - ~loc, - ) - ] - ] - ], - ) - } - }; - switch (result) { - | Some(fieldsStatuses) => - Update({...state, fieldsStatuses}) - | None => NoUpdate - }; - }; - }, - ) - ); - let rest_actions = [ - Exp.case( - [%pat? Submit], - switch%expr (state.formStatus) { - | Submitting(_) => NoUpdate - | Editing - | Submitted - | SubmissionFailed(_) => - switch (state.input->validateForm(~validators)) { - | Ok({output, fieldsStatuses}) => - UpdateWithSideEffects( - { - ...state, - fieldsStatuses, - formStatus: - Submitting( - switch (state.formStatus) { - | SubmissionFailed(error) => Some(error) - | Editing - | Submitted - | Submitting(_) => None - }, - ), - submissionStatus: AttemptedToSubmit, - }, - ({dispatch}) => - output->onSubmit({ - notifyOnSuccess: input => - SetSubmittedStatus(input)->dispatch, - notifyOnFailure: error => - SetSubmissionFailedStatus(error)->dispatch, - reset: () => Reset->dispatch, - dismissSubmissionResult: () => - DismissSubmissionResult->dispatch, - }), - ) - | Error({fieldsStatuses}) => - Update({ - ...state, - fieldsStatuses, - formStatus: Editing, - submissionStatus: AttemptedToSubmit, - }) - } - }, - ), - Exp.case( - [%pat? SetSubmittedStatus(input)], - switch%expr (input) { - | Some(input) => - Update({ - ...state, - input, - formStatus: Submitted, - fieldsStatuses: input->initialFieldsStatuses, - }) - | None => - Update({ - ...state, - formStatus: Submitted, - fieldsStatuses: state.input->initialFieldsStatuses, - }) - }, - ), - Exp.case( - [%pat? SetSubmissionFailedStatus(error)], - [%expr - Update({...state, formStatus: SubmissionFailed(error)}) - ], - ), - Exp.case( - [%pat? MapSubmissionError(map)], - switch%expr (state.formStatus) { - | Submitting(Some(error)) => - Update({...state, formStatus: Submitting(Some(error->map))}) - | SubmissionFailed(error) => - Update({...state, formStatus: SubmissionFailed(error->map)}) - | Editing - | Submitting(None) - | Submitted => NoUpdate - }, - ), - Exp.case( - [%pat? DismissSubmissionError], - switch%expr (state.formStatus) { - | Editing - | Submitting(_) - | Submitted => NoUpdate - | SubmissionFailed(_) => Update({...state, formStatus: Editing}) - }, - ), - Exp.case( - [%pat? DismissSubmissionResult], - switch%expr (state.formStatus) { - | Editing - | Submitting(_) => NoUpdate - | Submitted - | SubmissionFailed(_) => Update({...state, formStatus: Editing}) - }, - ), - Exp.case( - [%pat? Reset], - [%expr Update(initialInput->initialState)], - ), - ]; - Exp.match( - [%expr action], - rest_actions - |> List.append(blur_actions) - |> List.append(update_actions), - ); - } - }); - - // Interface - %e - { - let base = [ - ("input", [%expr state.input]), - ("status", [%expr state.formStatus]), - ( - "dirty", - [%expr - () => [%e - Exp.match( - [%expr state.fieldsStatuses], - [ - Exp.case( - Pat.record( - fields - |> List.map((field: FieldSpec.t) => - ( - Lident(field.id |> Field.to_string) |> lid(~loc), - [%pat? Pristine], - ) - ), - Closed, - ), - [%expr false], - ), - Exp.case([%pat? _], [%expr true]), - ], - ) - ] - ], - ), - ( - "valid", - [%expr - () => - switch (state.input->validateForm(~validators)) { - | Ok(_) => true - | Error(_) => false - } - ], - ), - ( - "submitting", - switch%expr (state.formStatus) { - | Submitting(_) => true - | Editing - | Submitted - | SubmissionFailed(_) => false - }, - ), - ("submit", [%expr () => Submit->dispatch]), - ( - "mapSubmissionError", - [%expr map => MapSubmissionError(map)->dispatch], - ), - ( - "dismissSubmissionError", - [%expr () => DismissSubmissionError->dispatch], - ), - ( - "dismissSubmissionResult", - [%expr () => DismissSubmissionResult->dispatch], - ), - ("reset", [%expr () => Reset->dispatch]), - ]; - let update_fns = - fields - |> List.map((field: FieldSpec.t) => { - ( - field.id |> Field.update_fn, - [%expr - input => - [%e - Exp.construct( - Lident(field.id |> Field.update_action) |> lid(~loc), - Some([%expr input]), - ) - ] - ->dispatch - ], - ) - }); - let blur_fns = - fields - |> List.map((field: FieldSpec.t) => { - ( - field.id |> Field.blur_fn, - [%expr - () => - [%e - Exp.construct( - Lident(field.id |> Field.blur_action) |> lid(~loc), - None, - ) - ] - ->dispatch - ], - ) - }); - let result_fns = - fields - |> List.map((field: FieldSpec.t) => { - ( - field.id |> Field.result_fn, - [%expr - () => { - exposeFieldResult( - [%e - field.id - |> E.field2(~of_=("state", "fieldsStatuses"), ~loc) - ], - ); - } - ], - ) - }); - - E.record( - ~loc, - result_fns - |> List.append(blur_fns) - |> List.append(update_fns) - |> List.append(base), - ); - }; - } -]; - let ext = Extension.declare( "form", @@ -989,47 +13,122 @@ let ext = (~loc, ~path as _, expr) => { switch (expr) { | PStr(structure) => - switch (structure |> Data.make) { - | Ok(data) => - Mod.mk( - Pmod_structure([ - open_formality(~loc), - input_type(data.input_type), - output_type(data.output_type), - message_type(data.message_type), - submission_error_type(data.submission_error_type), - validators_type(~loc, data.fields), - fields_statuses_type(~loc, data.fields), - state_type(~loc), - action_type(~loc, data.fields), - interface_type(~loc, data.fields), - initial_fields_statuses_fn(~loc, data.fields), - initial_state_fn(~loc), - validate_form_fn(~loc, data.fields), - use_form_fn(~loc, data.fields), - ]), - ) + switch (structure |> Metadata.make) { + | Ok({ + scheme, + async, + input_type, + output_type, + message_type, + submission_error_type, + }) => + let structure = [ + // TODO: Instead of placing core types on top, + // replace those in the structures + // as there might be the cases when some types + // would be defined above and required for anything + Form_OpenFormality.ast(~loc), + Form_InputType.ast(input_type), + Form_OutputType.ast(output_type), + Form_MessageType.ast(message_type), + Form_SubmissionErrorType.ast(submission_error_type), + Form_ValidatorsType.ast(~loc, scheme), + Form_FieldsStatusesType.ast(~loc, scheme), + Form_StateType.ast(~loc), + Form_ActionType.ast(~loc, scheme), + Form_InterfaceType.ast(~loc, ~async, scheme), + // Replacing validators record with intercepted one + // Keeping the rest of the stuff in there + ...List.fold_right( + (structure_item, acc) => + switch (structure_item) { + | {pstr_desc: Pstr_type(rec_flag, decls), pstr_loc} => + // TODO: Replace instead of filtering out + let decls = + decls + |> List.filter( + fun + | {ptype_name: {txt: "input"}} + | {ptype_name: {txt: "output"}} + | {ptype_name: {txt: "message"}} + | {ptype_name: {txt: "submissionError"}} => false + | _ => true, + ); + switch (decls) { + | [] => acc + | _ => [ + {pstr_desc: Pstr_type(rec_flag, decls), pstr_loc}, + ...acc, + ] + }; + | {pstr_desc: Pstr_value(rec_flag, values), pstr_loc} + when values |> ValidatorsRecordParser.have_validators => + // Updating validators record + let values = + values + |> List.map( + fun + | { + pvb_pat: { + ppat_desc: Ppat_var({txt: "validators"}), + }, + } as value => + value |> Form_ValidatorsRecord.ast(scheme) + | _ as value => value, + ); + [ + {pstr_desc: Pstr_value(rec_flag, values), pstr_loc}, + ...acc, + ]; + // Not touching the rest + | _ as structure_item => [structure_item, ...acc] + }, + structure, + [ + // All funcs are at the bottom of the module + Form_InitialFieldsStatusesFn.ast(~loc, scheme), + Form_InitialStateFn.ast(~loc), + async + ? Form_ValidateFormFn_Async.ast(~loc, scheme) + : Form_ValidateFormFn_Sync.ast(~loc, scheme), + Form_UseFormFn.ast(~loc, ~async, scheme), + ], + ), + ]; + + Mod.mk(Pmod_structure(structure)); + | Error(InputTypeParseError(NotFound)) => Location.raise_errorf(~loc, "`input` type not found") | Error(InputTypeParseError(NotRecord(loc))) => Location.raise_errorf(~loc, "`input` must be of record type") + | Error(InputTypeParseError(InvalidAsyncField(InvalidPayload(loc)))) => + Location.raise_errorf( + ~loc, + "`@field.async` attribute accepts only optional record `{mode: OnChange | OnBlur}`", + ) + | Error(InputTypeParseError(InvalidAsyncField(InvalidAsyncMode(loc)))) => + Location.raise_errorf( + ~loc, + "Invalid async mode. Use either `OnChange` or `OnBlur`.", + ) | Error(InputTypeParseError(InvalidFieldDeps(DepsParseError(loc)))) => Location.raise_errorf( ~loc, - "[@field.deps] attribute must contain field or tuple of fields", + "`@field.deps` attribute must contain field or tuple of fields", ) | Error( InputTypeParseError( InvalidFieldDeps(DepNotFound(`Field(dep, loc))), ), ) => - Location.raise_errorf(~loc, "Field %s doesn't exist in input", dep) + Location.raise_errorf(~loc, "Field `%s` doesn't exist in input", dep) | Error( InputTypeParseError( InvalidFieldDeps(DepOfItself(`Field(dep, loc))), ), ) => - Location.raise_errorf(~loc, "Field can't depend on itself") + Location.raise_errorf(~loc, "Field `%s` depends on itself", dep) | Error( InputTypeParseError( InvalidFieldDeps(DepDuplicate(`Field(dep, loc))), @@ -1037,7 +136,7 @@ let ext = ) => Location.raise_errorf( ~loc, - "Field %s is already declared as a dependency for this field", + "Field `%s` is already declared as a dependency for this field", dep, ) | Error(OutputTypeParseError(NotFound)) => @@ -1052,6 +151,48 @@ let ext = ~loc, "`output` can only be an alias of `input` type or a record", ) + | Error(ValidatorsRecordParseError(NotFound)) => + Location.raise_errorf(~loc, "`validators` record not found") + | Error( + ValidatorsRecordParseError(NotRecord(loc) | RecordParseError(loc)), + ) => + Location.raise_errorf( + ~loc, + "Failed to parse `validators` record. Please, file an issue with your use-case.", + ) + | Error(ValidatorsRecordParseError(BadTypeAnnotation(loc))) => + Location.raise_errorf( + ~loc, + "`validators` binding must be of `validators` type. You can safely remove type annotation and it will be annotated for you under the hood.", + ) + | Error( + ValidatorsRecordParseError( + ValidatorError( + `BadRequiredValidator(field, `Some(loc) | `None(loc), reason), + ), + ), + ) => + switch (reason) { + | `DifferentIO(input_type, output_type) => + Location.raise_errorf( + ~loc, + "Validator for `%s` field is required because its input and output types are different. So validator function is required to produce value of output type from an input value.", + switch (field) { + | Field(field) => field + }, + ) + | `IncludedInDeps(in_deps_of_field) => + Location.raise_errorf( + ~loc, + "Validator for `%s` field is required because this field is included in deps of `%s` field", + switch (field) { + | Field(field) => field + }, + switch (in_deps_of_field) { + | Field(field) => field + }, + ) + } | Error(IOMismatch(OutputFieldsNotInInput({fields}))) => switch (fields) { | [] => @@ -1063,7 +204,9 @@ let ext = Location.raise_errorf( ~loc, "`output` field `%s` doesn't exist in `input` type", - field |> Field.to_string, + switch (field) { + | Field(field) => field + }, ) } | Error(IOMismatch(InputFieldsNotInOutput({fields, loc}))) @@ -1078,20 +221,26 @@ let ext = ) => switch (fields) { | [] => - failwith( - "Empty list of non-matched fields in IOMatchError(Both)", - ) + failwith("Empty list of non-matched fields in IOMatchError(Both)") | [field] => Location.raise_errorf( ~loc, "`input` field `%s` doesn't exist in `output` type", - field |> Field.to_string, + switch (field) { + | Field(field) => field + }, ) | fields => Location.raise_errorf( ~loc, "Some `input` fields don't exist in `output` type: %s", - fields |> List.map(Field.to_string) |> String.concat(", "), + fields + |> List.map((field: Field.t) => + switch (field) { + | Field(field) => field + } + ) + |> String.concat(", "), ) } } diff --git a/lib/ppx/Form_ActionType.re b/lib/ppx/Form_ActionType.re new file mode 100644 index 00000000..3c3eed7a --- /dev/null +++ b/lib/ppx/Form_ActionType.re @@ -0,0 +1,85 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => { + let update_actions = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + Field.Field(name) + |> Field.update_action + |> T.constructor(~args=[[%type: input]], ~loc) + } + ); + + let blur_actions = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + Field.Field(name) |> Field.blur_action |> T.constructor(~loc) + } + ); + + let apply_async_result_actions = + scheme + |> List.fold_left( + (acc, entry: Scheme.entry) => + switch (entry) { + | Field({validator: SyncValidator(_)}) => acc + | Field({name, validator: AsyncValidator(_), output_type}) => [ + Field.Field(name) + |> Field.apply_async_result_action + |> T.constructor( + ~args=[ + output_type |> FieldType.unpack, + Typ.constr( + Lident("result") |> lid(~loc), + [ + output_type |> FieldType.unpack, + Typ.constr(Lident("message") |> lid(~loc), []), + ], + ), + ], + ~loc, + ), + ...acc, + ] + }, + [], + ); + + let rest_actions = [ + "Submit" |> T.constructor(~loc), + "SetSubmittedStatus" + |> T.constructor(~args=[[%type: option(input)]], ~loc), + "SetSubmissionFailedStatus" + |> T.constructor(~args=[[%type: submissionError]], ~loc), + "MapSubmissionError" + |> T.constructor( + ~args=[[%type: submissionError => submissionError]], + ~loc, + ), + "DismissSubmissionError" |> T.constructor(~loc), + "DismissSubmissionResult" |> T.constructor(~loc), + "Reset" |> T.constructor(~loc), + ]; + + "action" + |> str(~loc) + |> Type.mk( + ~kind= + Ptype_variant( + rest_actions + |> List.append(apply_async_result_actions) + |> List.append(blur_actions) + |> List.append(update_actions), + ), + ) + |> StructureItem.from_type_declaration(~loc, ~rec_flag=Recursive); +}; diff --git a/lib/ppx/Form_FieldsStatusesType.re b/lib/ppx/Form_FieldsStatusesType.re new file mode 100644 index 00000000..296135f3 --- /dev/null +++ b/lib/ppx/Form_FieldsStatusesType.re @@ -0,0 +1,21 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => { + scheme + |> T.record_of_fields( + ~name="fieldsStatuses", ~loc, ~typ=(~validator, ~output_type) => + switch (validator) { + | SyncValidator(_) => [%type: + fieldStatus([%t output_type |> FieldType.unpack], message) + ] + | AsyncValidator(_) => [%type: + Async.fieldStatus([%t output_type |> FieldType.unpack], message) + ] + } + ); +}; diff --git a/lib/ppx/Form_InitialFieldsStatusesFn.re b/lib/ppx/Form_InitialFieldsStatusesFn.re new file mode 100644 index 00000000..4d56fa65 --- /dev/null +++ b/lib/ppx/Form_InitialFieldsStatusesFn.re @@ -0,0 +1,25 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => { + [%stri + let initialFieldsStatuses = (_input: input): fieldsStatuses => [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + ( + switch (entry) { + | Field({name}) => Lident(name) |> lid(~loc) + }, + [%expr Pristine], + ) + ), + None, + ) + ] + ]; +}; diff --git a/lib/ppx/Form_InitialStateFn.re b/lib/ppx/Form_InitialStateFn.re new file mode 100644 index 00000000..6dca133b --- /dev/null +++ b/lib/ppx/Form_InitialStateFn.re @@ -0,0 +1,15 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc) => [%stri + let initialState = input => { + input, + fieldsStatuses: input->initialFieldsStatuses, + formStatus: Editing, + submissionStatus: NeverSubmitted, + } +]; diff --git a/lib/ppx/Form_InputType.re b/lib/ppx/Form_InputType.re new file mode 100644 index 00000000..2fef01d3 --- /dev/null +++ b/lib/ppx/Form_InputType.re @@ -0,0 +1,10 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (input_type: InputType.t) => { + input_type |> InputType.structure_item; +}; diff --git a/lib/ppx/Form_InterfaceType.re b/lib/ppx/Form_InterfaceType.re new file mode 100644 index 00000000..91c97fcf --- /dev/null +++ b/lib/ppx/Form_InterfaceType.re @@ -0,0 +1,88 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, ~async: bool, scheme: Scheme.t) => { + let f = (x, t) => t |> Type.field(x |> str(~loc)); + + let base = [ + f("input", [%type: input]), + f("status", [%type: formStatus(submissionError)]), + f("dirty", [%type: unit => bool]), + f( + "valid", + async ? [%type: unit => option(bool)] : [%type: unit => bool], + ), + f("submitting", [%type: bool]), + f("submit", [%type: unit => unit]), + f("dismissSubmissionError", [%type: unit => unit]), + f("dismissSubmissionResult", [%type: unit => unit]), + f( + "mapSubmissionError", + [%type: (submissionError => submissionError) => unit], + ), + f("reset", [%type: unit => unit]), + ]; + + let update_fns = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + f(Field.(Field(name) |> update_fn), [%type: input => unit]) + } + ); + + let blur_fns = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + f(Field.(Field(name) |> blur_fn), [%type: unit => unit]) + } + ); + + let result_fns = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name, validator, output_type}) => + f( + Field.(Field(name) |> result_fn), + switch (validator) { + | SyncValidator(_) => [%type: + unit => + option( + result([%t output_type |> FieldType.unpack], message), + ) + ] + | AsyncValidator(_) => [%type: + unit => + option( + Async.exposedFieldStatus( + [%t output_type |> FieldType.unpack], + message, + ), + ) + ] + }, + ) + } + ); + + "interface" + |> str(~loc) + |> Type.mk( + ~kind= + Ptype_record( + base + |> List.append(result_fns) + |> List.append(blur_fns) + |> List.append(update_fns), + ), + ) + |> StructureItem.from_type_declaration(~loc, ~rec_flag=Recursive); +}; diff --git a/lib/ppx/Form_MessageType.re b/lib/ppx/Form_MessageType.re new file mode 100644 index 00000000..e8c1e3e5 --- /dev/null +++ b/lib/ppx/Form_MessageType.re @@ -0,0 +1,9 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (message_type: MessageType.t) => + message_type |> MessageType.structure_item; diff --git a/lib/ppx/Form_OpenFormality.re b/lib/ppx/Form_OpenFormality.re new file mode 100644 index 00000000..c8e99600 --- /dev/null +++ b/lib/ppx/Form_OpenFormality.re @@ -0,0 +1,8 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc) => [%stri open Formality]; diff --git a/lib/ppx/Form_OutputType.re b/lib/ppx/Form_OutputType.re new file mode 100644 index 00000000..11eb4a43 --- /dev/null +++ b/lib/ppx/Form_OutputType.re @@ -0,0 +1,10 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (output_type: OutputType.t) => { + output_type |> OutputType.structure_item; +}; diff --git a/lib/ppx/Form_StateType.re b/lib/ppx/Form_StateType.re new file mode 100644 index 00000000..f438157d --- /dev/null +++ b/lib/ppx/Form_StateType.re @@ -0,0 +1,15 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc) => [%stri + type state = { + input, + fieldsStatuses, + formStatus: formStatus(submissionError), + submissionStatus, + } +]; diff --git a/lib/ppx/Form_SubmissionErrorType.re b/lib/ppx/Form_SubmissionErrorType.re new file mode 100644 index 00000000..089a3980 --- /dev/null +++ b/lib/ppx/Form_SubmissionErrorType.re @@ -0,0 +1,9 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (submission_error_type: SubmissionErrorType.t) => + submission_error_type |> SubmissionErrorType.structure_item; diff --git a/lib/ppx/Form_UseFormFn.re b/lib/ppx/Form_UseFormFn.re new file mode 100644 index 00000000..0ce112b7 --- /dev/null +++ b/lib/ppx/Form_UseFormFn.re @@ -0,0 +1,39 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, ~async: bool, scheme: Scheme.t) => [%stri + let useForm = + ( + ~initialInput: input, + ~onSubmit: + (output, submissionCallbacks(input, submissionError)) => unit, + ) => { + let memoizedInitialState = + React.useMemo1(() => initialInput->initialState, [|initialInput|]); + + let (state, dispatch) = + memoizedInitialState->ReactUpdate.useReducer((state, action) => { + %e + { + Exp.match( + [%expr action], + Form_UseFormFn_RestActions.ast(~loc, ~async) + |> List.append( + Form_UseFormFn_ApplyAsyncResultActions.ast(~loc, scheme), + ) + |> List.append(Form_UseFormFn_BlurActions.ast(~loc, scheme)) + |> List.append(Form_UseFormFn_UpdateActions.ast(~loc, scheme)), + ); + } + }); + + %e + { + Form_UseFormFn_Interface.ast(~loc, ~async, scheme); + }; + } +]; diff --git a/lib/ppx/Form_UseFormFn_ApplyAsyncResultActions.re b/lib/ppx/Form_UseFormFn_ApplyAsyncResultActions.re new file mode 100644 index 00000000..26099628 --- /dev/null +++ b/lib/ppx/Form_UseFormFn_ApplyAsyncResultActions.re @@ -0,0 +1,63 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => + scheme + |> List.fold_left( + (acc, entry: Scheme.entry) => + switch (entry) { + | Field({validator: SyncValidator(_)}) => acc + | Field({name, validator}) => + let field = Field.Field(name); + [ + Exp.case( + Pat.construct( + Lident(field |> Field.apply_async_result_action) + |> lid(~loc), + Some( + Pat.tuple([ + Pat.var("value" |> str(~loc)), + Pat.var("result" |> str(~loc)), + ]), + ), + ), + { + %expr + { + let validator = [%e + field |> E.field(~of_="validators", ~loc) + ]; + switch ( + [%e + field + |> E.field2(~of_=("state", "fieldsStatuses"), ~loc) + ] + ) { + | Validating(x) when validator.eq(x, value) => + Update({ + ...state, + fieldsStatuses: [%e + field + |> E.update_field2( + ~of_=("state", "fieldsStatuses"), + ~with_=[%expr Dirty(result, Shown)], + ~loc, + ) + ], + }) + | Validating(_) + | Pristine + | Dirty(_, Shown | Hidden) => NoUpdate + }; + }; + }, + ), + ...acc, + ]; + }, + [], + ); diff --git a/lib/ppx/Form_UseFormFn_BlurActions.re b/lib/ppx/Form_UseFormFn_BlurActions.re new file mode 100644 index 00000000..faad7bfd --- /dev/null +++ b/lib/ppx/Form_UseFormFn_BlurActions.re @@ -0,0 +1,56 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name, validator}) => + let field = Field.Field(name); + Exp.case( + Pat.construct( + Lident(field |> Field.blur_action) |> lid(~loc), + None, + ), + { + let field_status_expr = + field |> E.field2(~of_=("state", "fieldsStatuses"), ~loc); + let field_input_expr = + field |> E.field2(~of_=("state", "input"), ~loc); + let validator_expr = field |> E.field(~of_="validators", ~loc); + let set_status_expr = + field + |> E.update_field2( + ~of_=("state", "fieldsStatuses"), + ~with_=[%expr status], + ~loc, + ); + + switch (validator) { + | SyncValidator(validator) => + Form_UseFormFn_BlurActions_Sync.ast( + ~loc, + ~validator, + ~field_status_expr, + ~field_input_expr, + ~validator_expr, + ~set_status_expr, + ) + | AsyncValidator({optionality}) => + Form_UseFormFn_BlurActions_Async.ast( + ~loc, + ~field, + ~optionality, + ~field_status_expr, + ~validator_expr, + ~set_status_expr, + ) + }; + }, + ); + } + ); diff --git a/lib/ppx/Form_UseFormFn_BlurActions_Async.re b/lib/ppx/Form_UseFormFn_BlurActions_Async.re new file mode 100644 index 00000000..efdb76c6 --- /dev/null +++ b/lib/ppx/Form_UseFormFn_BlurActions_Async.re @@ -0,0 +1,80 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = + ( + ~loc, + ~field: Field.t, + ~optionality: option(FieldOptionality.t), + ~field_status_expr: expression, + ~validator_expr: expression, + ~set_status_expr: expression, + ) => { + %expr + { + let result = + switch%e (optionality) { + | None => + %expr + { + Async.validateFieldOnBlur( + ~input=state.input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(OptionType) => + %expr + { + Async.validateFieldOfOptionTypeOnBlur( + ~input=state.input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(StringType) => + %expr + { + Async.validateFieldOfStringTypeOnBlur( + ~input=state.input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(OptionStringType) => + %expr + { + Async.validateFieldOfOptionStringTypeOnBlur( + ~input=state.input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + }; + + switch (result) { + | None => NoUpdate + | Some(fieldsStatuses) => + switch ([%e field |> E.field(~of_="fieldsStatuses", ~loc)]) { + | Validating(value) => + UpdateWithSideEffects( + {...state, fieldsStatuses}, + ({dispatch}) => { + // TODO: async cb + Js.log2("async", value) + }, + ) + | Pristine + | Dirty(_, Shown | Hidden) => Update({...state, fieldsStatuses}) + } + }; + }; +}; diff --git a/lib/ppx/Form_UseFormFn_BlurActions_Sync.re b/lib/ppx/Form_UseFormFn_BlurActions_Sync.re new file mode 100644 index 00000000..9b02fe5a --- /dev/null +++ b/lib/ppx/Form_UseFormFn_BlurActions_Sync.re @@ -0,0 +1,44 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = + ( + ~loc, + ~validator: result(FieldValidator.sync, unit), + ~field_status_expr: expression, + ~field_input_expr: expression, + ~validator_expr: expression, + ~set_status_expr: expression, + ) => { + %expr + { + let result = + switch%e (validator) { + | Ok(Required | Optional(Some(_))) + | Error () => + %expr + validateFieldOnBlurWithValidator( + ~input=state.input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ) + | Ok(Optional(None)) => + %expr + validateFieldOnBlurWithoutValidator( + ~fieldInput=[%e field_input_expr], + ~fieldStatus=[%e field_status_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ) + }; + + switch (result) { + | Some(fieldsStatuses) => Update({...state, fieldsStatuses}) + | None => NoUpdate + }; + }; +}; diff --git a/lib/ppx/Form_UseFormFn_Interface.re b/lib/ppx/Form_UseFormFn_Interface.re new file mode 100644 index 00000000..5f5a3e0c --- /dev/null +++ b/lib/ppx/Form_UseFormFn_Interface.re @@ -0,0 +1,176 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, ~async: bool, scheme: Scheme.t) => { + let base = [ + ("input", [%expr state.input]), + ("status", [%expr state.formStatus]), + ( + "dirty", + [%expr + () => [%e + Exp.match( + [%expr state.fieldsStatuses], + [ + Exp.case( + Pat.record( + scheme + |> List.map((entry: Scheme.entry) => + ( + switch (entry) { + | Field({name}) => Lident(name) |> lid(~loc) + }, + [%pat? Pristine], + ) + ), + Closed, + ), + [%expr false], + ), + Exp.case([%pat? _], [%expr true]), + ], + ) + ] + ], + ), + ( + "valid", + if (async) { + %expr + () => + switch ( + state.input + ->validateForm(~validators, ~fieldsStatuses=state.fieldsStatuses) + ) { + | None => None + | Some(Valid(_)) => Some(true) + | Some(Invalid(_)) => Some(false) + }; + } else { + %expr + () => + switch ( + state.input + ->validateForm(~validators, ~fieldsStatuses=state.fieldsStatuses) + ) { + | Valid(_) => true + | Invalid(_) => false + }; + }, + ), + ( + "submitting", + switch%expr (state.formStatus) { + | Submitting(_) => true + | Editing + | Submitted + | SubmissionFailed(_) => false + }, + ), + ("submit", [%expr () => Submit->dispatch]), + ("mapSubmissionError", [%expr map => MapSubmissionError(map)->dispatch]), + ( + "dismissSubmissionError", + [%expr () => DismissSubmissionError->dispatch], + ), + ( + "dismissSubmissionResult", + [%expr () => DismissSubmissionResult->dispatch], + ), + ("reset", [%expr () => Reset->dispatch]), + ]; + + let update_fns = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Field.(Field(name) |> update_fn), + [%expr + ( + input => + [%e + Exp.construct( + Lident(Field.(Field(name) |> update_action)) + |> lid(~loc), + Some([%expr input]), + ) + ] + ->dispatch + ) + ], + ) + } + ); + + let blur_fns = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Field.(Field(name) |> blur_fn), + [%expr + ( + () => + [%e + Exp.construct( + Lident(Field.(Field(name) |> blur_action)) + |> lid(~loc), + None, + ) + ] + ->dispatch + ) + ], + ) + } + ); + + let result_fns = + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name, validator}) => ( + Field.(Field(name) |> result_fn), + switch (validator) { + | SyncValidator(_) => + %expr + ( + () => { + exposeFieldResult( + [%e + Field.Field(name) + |> E.field2(~of_=("state", "fieldsStatuses"), ~loc) + ], + ); + } + ) + | AsyncValidator(_) => + %expr + ( + () => { + Async.exposeFieldResult( + [%e + Field.Field(name) + |> E.field2(~of_=("state", "fieldsStatuses"), ~loc) + ], + ); + } + ) + }, + ) + } + ); + + E.record( + ~loc, + result_fns + |> List.append(blur_fns) + |> List.append(update_fns) + |> List.append(base), + ); +}; diff --git a/lib/ppx/Form_UseFormFn_RestActions.re b/lib/ppx/Form_UseFormFn_RestActions.re new file mode 100644 index 00000000..19e347b4 --- /dev/null +++ b/lib/ppx/Form_UseFormFn_RestActions.re @@ -0,0 +1,160 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, ~async) => [ + if (async) { + Exp.case( + [%pat? Submit], + switch%expr (state.formStatus) { + | Submitting(_) => NoUpdate + | Editing + | Submitted + | SubmissionFailed(_) => + switch ( + state.input + ->validateForm(~validators, ~fieldsStatuses=state.fieldsStatuses) + ) { + | None => NoUpdate + | Some(Valid({output, fieldsStatuses})) => + UpdateWithSideEffects( + { + ...state, + fieldsStatuses, + formStatus: + Submitting( + switch (state.formStatus) { + | SubmissionFailed(error) => Some(error) + | Editing + | Submitted + | Submitting(_) => None + }, + ), + submissionStatus: AttemptedToSubmit, + }, + ({dispatch}) => + output->onSubmit({ + notifyOnSuccess: input => SetSubmittedStatus(input)->dispatch, + notifyOnFailure: error => + SetSubmissionFailedStatus(error)->dispatch, + reset: () => Reset->dispatch, + dismissSubmissionResult: () => + DismissSubmissionResult->dispatch, + }), + ) + | Some(Invalid({fieldsStatuses})) => + Update({ + ...state, + fieldsStatuses, + formStatus: Editing, + submissionStatus: AttemptedToSubmit, + }) + } + }, + ); + } else { + Exp.case( + [%pat? Submit], + switch%expr (state.formStatus) { + | Submitting(_) => NoUpdate + | Editing + | Submitted + | SubmissionFailed(_) => + switch ( + state.input + ->validateForm(~validators, ~fieldsStatuses=state.fieldsStatuses) + ) { + | Valid({output, fieldsStatuses}) => + UpdateWithSideEffects( + { + ...state, + fieldsStatuses, + formStatus: + Submitting( + switch (state.formStatus) { + | SubmissionFailed(error) => Some(error) + | Editing + | Submitted + | Submitting(_) => None + }, + ), + submissionStatus: AttemptedToSubmit, + }, + ({dispatch}) => + output->onSubmit({ + notifyOnSuccess: input => SetSubmittedStatus(input)->dispatch, + notifyOnFailure: error => + SetSubmissionFailedStatus(error)->dispatch, + reset: () => Reset->dispatch, + dismissSubmissionResult: () => + DismissSubmissionResult->dispatch, + }), + ) + | Invalid({fieldsStatuses}) => + Update({ + ...state, + fieldsStatuses, + formStatus: Editing, + submissionStatus: AttemptedToSubmit, + }) + } + }, + ); + }, + Exp.case( + [%pat? SetSubmittedStatus(input)], + switch%expr (input) { + | Some(input) => + Update({ + ...state, + input, + formStatus: Submitted, + fieldsStatuses: input->initialFieldsStatuses, + }) + | None => + Update({ + ...state, + formStatus: Submitted, + fieldsStatuses: state.input->initialFieldsStatuses, + }) + }, + ), + Exp.case( + [%pat? SetSubmissionFailedStatus(error)], + [%expr Update({...state, formStatus: SubmissionFailed(error)})], + ), + Exp.case( + [%pat? MapSubmissionError(map)], + switch%expr (state.formStatus) { + | Submitting(Some(error)) => + Update({...state, formStatus: Submitting(Some(error->map))}) + | SubmissionFailed(error) => + Update({...state, formStatus: SubmissionFailed(error->map)}) + | Editing + | Submitting(None) + | Submitted => NoUpdate + }, + ), + Exp.case( + [%pat? DismissSubmissionError], + switch%expr (state.formStatus) { + | Editing + | Submitting(_) + | Submitted => NoUpdate + | SubmissionFailed(_) => Update({...state, formStatus: Editing}) + }, + ), + Exp.case( + [%pat? DismissSubmissionResult], + switch%expr (state.formStatus) { + | Editing + | Submitting(_) => NoUpdate + | Submitted + | SubmissionFailed(_) => Update({...state, formStatus: Editing}) + }, + ), + Exp.case([%pat? Reset], [%expr Update(initialInput->initialState)]), +]; diff --git a/lib/ppx/Form_UseFormFn_UpdateActions.re b/lib/ppx/Form_UseFormFn_UpdateActions.re new file mode 100644 index 00000000..c039e432 --- /dev/null +++ b/lib/ppx/Form_UseFormFn_UpdateActions.re @@ -0,0 +1,127 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name, deps, validator}) => + let field = Field.Field(name); + + Exp.case( + Pat.construct( + ~attrs=[explicit_arity(~loc)], + Lident(field |> Field.update_action) |> lid(~loc), + Some(Pat.tuple([Pat.var("input" |> str(~loc))])), + ), + switch (deps) { + | [] => + let field_status_expr = + field |> E.field2(~of_=("state", "fieldsStatuses"), ~loc); + let field_input_expr = field |> E.field(~of_="input", ~loc); + let validator_expr = field |> E.field(~of_="validators", ~loc); + let set_status_expr = + field + |> E.update_field2( + ~of_=("state", "fieldsStatuses"), + ~with_=[%expr status], + ~loc, + ); + + switch (validator) { + | SyncValidator(validator) => + Form_UseFormFn_UpdateActions_Sync.ast( + ~loc, + ~validator, + ~field_status_expr, + ~field_input_expr, + ~validator_expr, + ~set_status_expr, + ) + | AsyncValidator({mode: OnBlur, optionality}) => + Form_UseFormFn_UpdateActions_AsyncOnBlurMode.ast( + ~loc, + ~optionality, + ~field_status_expr, + ~validator_expr, + ~set_status_expr, + ) + | AsyncValidator({mode: OnChange, optionality}) => + Form_UseFormFn_UpdateActions_AsyncOnChangeMode.ast( + ~loc, + ~field, + ~optionality, + ~field_status_expr, + ~validator_expr, + ~set_status_expr, + ) + }; + + | [dep, ...deps] => + %expr + { + let nextFieldsStatuses = ref(state.fieldsStatuses); + + %e + { + Form_UseFormFn_UpdateActions_Deps.ast( + ~loc, + ~dep, + ~deps, + ~scheme, + ); + }; + + %e + { + let field_status_expr = + field |> E.ref_field(~of_="nextFieldsStatuses", ~loc); + let field_input_expr = field |> E.field(~of_="input", ~loc); + let validator_expr = + field |> E.field(~of_="validators", ~loc); + let set_status_expr = + field + |> E.update_ref_field( + ~of_="nextFieldsStatuses", + ~with_=[%expr status], + ~loc, + ); + + switch (validator) { + | SyncValidator(validator) => + Form_UseFormFn_UpdateActions_Sync.ast( + ~loc, + ~validator, + ~field_status_expr, + ~field_input_expr, + ~validator_expr, + ~set_status_expr, + ) + | AsyncValidator({mode: OnBlur, optionality}) => + Form_UseFormFn_UpdateActions_AsyncOnBlurMode.ast( + ~loc, + ~optionality, + ~field_status_expr, + ~validator_expr, + ~set_status_expr, + ) + | AsyncValidator({mode: OnChange, optionality}) => + Form_UseFormFn_UpdateActions_AsyncOnChangeMode.ast( + ~loc, + ~field, + ~optionality, + ~field_status_expr, + ~validator_expr, + ~set_status_expr, + ) + }; + }; + } + }, + ); + } + ); diff --git a/lib/ppx/Form_UseFormFn_UpdateActions_AsyncOnBlurMode.re b/lib/ppx/Form_UseFormFn_UpdateActions_AsyncOnBlurMode.re new file mode 100644 index 00000000..a5bd782c --- /dev/null +++ b/lib/ppx/Form_UseFormFn_UpdateActions_AsyncOnBlurMode.re @@ -0,0 +1,67 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = + ( + ~loc, + ~optionality: option(FieldOptionality.t), + ~field_status_expr: expression, + ~validator_expr: expression, + ~set_status_expr: expression, + ) => [%expr + Update({ + ...state, + input, + fieldsStatuses: + switch%e (optionality) { + | None => + %expr + { + Async.validateFieldOnChangeInOnBlurMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(OptionType) => + %expr + { + Async.validateFieldOfOptionTypeOnChangeInOnBlurMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(StringType) => + %expr + { + Async.validateFieldOfStringTypeOnChangeInOnBlurMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(OptionStringType) => + %expr + { + Async.validateFieldOfOptionStringTypeOnChangeInOnBlurMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + }, + }) +]; diff --git a/lib/ppx/Form_UseFormFn_UpdateActions_AsyncOnChangeMode.re b/lib/ppx/Form_UseFormFn_UpdateActions_AsyncOnChangeMode.re new file mode 100644 index 00000000..d95b9fbd --- /dev/null +++ b/lib/ppx/Form_UseFormFn_UpdateActions_AsyncOnChangeMode.re @@ -0,0 +1,80 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = + ( + ~loc, + ~field: Field.t, + ~optionality: option(FieldOptionality.t), + ~field_status_expr: expression, + ~validator_expr: expression, + ~set_status_expr: expression, + ) => { + %expr + { + let nextFieldsStatuses = + switch%e (optionality) { + | None => + %expr + { + Async.validateFieldOnChangeInOnChangeMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(OptionType) => + %expr + { + Async.validateFieldOfOptionTypeOnChangeInOnChangeMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(StringType) => + %expr + { + Async.validateFieldOfStringTypeOnChangeInOnChangeMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Some(OptionStringType) => + %expr + { + Async.validateFieldOfOptionStringTypeOnChangeInOnChangeMode( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + }; + switch ([%e field |> E.field(~of_="nextFieldsStatuses", ~loc)]) { + | Validating(value) => + UpdateWithSideEffects( + {...state, input, fieldsStatuses: nextFieldsStatuses}, + ({dispatch}) => { + // TODO: async cb + Js.log2("async", value) + }, + ) + | Pristine + | Dirty(_, Shown | Hidden) => + Update({...state, input, fieldsStatuses: nextFieldsStatuses}) + }; + }; +}; diff --git a/lib/ppx/Form_UseFormFn_UpdateActions_Deps.re b/lib/ppx/Form_UseFormFn_UpdateActions_Deps.re new file mode 100644 index 00000000..4549effb --- /dev/null +++ b/lib/ppx/Form_UseFormFn_UpdateActions_Deps.re @@ -0,0 +1,66 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, ~dep: Field.t, ~deps: list(Field.t), ~scheme: Scheme.t) => { + let validate_dep = (dep: Field.t) => { + let (dep_field, dep_validator) = + switch ( + scheme + |> List.find((entry: Scheme.entry) => + switch (entry, dep) { + | (Field({name}), Field(dep)) => name == dep + } + ) + ) { + | Field({name, validator}) => (Field.Field(name), validator) + }; + + let field_status_expr = + dep_field |> E.ref_field(~of_="nextFieldsStatuses", ~loc); + let validator_expr = dep_field |> E.field(~of_="validators", ~loc); + let set_status_expr = + dep_field + |> E.update_ref_field( + ~of_="nextFieldsStatuses", + ~with_=[%expr status], + ~loc, + ); + + switch (dep_validator) { + | SyncValidator(Ok(Required | Optional(Some(_))) | Error ()) => + switch%expr ( + validateFieldDependencyOnChange( + ~input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ) + ) { + | Some(result) => nextFieldsStatuses := result + | None => () + } + | SyncValidator(Ok(Optional(None))) => + %expr + () + // Should we trigger async validator of dependency? + | AsyncValidator({mode: OnChange | OnBlur}) => + switch%expr ( + Async.validateFieldDependencyOnChange( + ~input, + ~fieldStatus=[%e field_status_expr], + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ) + ) { + | Some(result) => nextFieldsStatuses := result + | None => () + } + }; + }; + + deps |> E.seq(~exp=dep |> validate_dep, ~make=validate_dep); +}; diff --git a/lib/ppx/Form_UseFormFn_UpdateActions_Sync.re b/lib/ppx/Form_UseFormFn_UpdateActions_Sync.re new file mode 100644 index 00000000..9f626457 --- /dev/null +++ b/lib/ppx/Form_UseFormFn_UpdateActions_Sync.re @@ -0,0 +1,42 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = + ( + ~loc, + ~validator: result(FieldValidator.sync, unit), + ~field_status_expr: expression, + ~field_input_expr: expression, + ~validator_expr: expression, + ~set_status_expr: expression, + ) => [%expr + Update({ + ...state, + input, + fieldsStatuses: + switch%e (validator) { + | Ok(Required | Optional(Some(_))) + | Error () => + %expr + { + validateFieldOnChangeWithValidator( + ~input, + ~fieldStatus=[%e field_status_expr], + ~submissionStatus=state.submissionStatus, + ~validator=[%e validator_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ); + } + | Ok(Optional(None)) => + %expr + validateFieldOnChangeWithoutValidator( + ~fieldInput=[%e field_input_expr], + ~setStatus=[%e [%expr status => [%e set_status_expr]]], + ) + }, + }) +]; diff --git a/lib/ppx/Form_ValidateFormFn_Async.re b/lib/ppx/Form_ValidateFormFn_Async.re new file mode 100644 index 00000000..db0eb724 --- /dev/null +++ b/lib/ppx/Form_ValidateFormFn_Async.re @@ -0,0 +1,345 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => { + let field_result = x => (x |> Field.to_camelized_string) ++ "Result"; + let field_result_visibility = x => + (x |> Field.to_camelized_string) ++ "ResultVisibility"; + + // We are going to pattern match against validation results of each field + [%stri + let validateForm = + ( + input: input, + ~validators: validators, + ~fieldsStatuses: fieldsStatuses, + ) + : option(formValidationResult(output, fieldsStatuses)) => { + %e + { + let match_values = + Exp.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({ + name, + validator: + SyncValidator( + Ok(Required | Optional(Some(_))) | Error (), + ), + }) => + %expr + { + ( + switch ( + [%e + Field.Field(name) + |> E.field(~of_="fieldsStatuses", ~loc) + ] + ) { + | Pristine => + let validator = [%e + Field.Field(name) + |> E.field(~of_="validators", ~loc) + ]; + validator.validate(input); + | Dirty(result, _) => result + }, + Shown, + ); + } + | Field({ + name, + validator: SyncValidator(Ok(Optional(None))), + }) => + %expr + ( + Ok( + [%e Field.Field(name) |> E.field(~of_="input", ~loc)], + ), + Hidden, + ) + | Field({name, validator: AsyncValidator(_)}) => + %expr + { + ( + switch ( + [%e + Field.Field(name) + |> E.field(~of_="fieldsStatuses", ~loc) + ] + ) { + | Validating(x) => `Validating(x) + | Pristine => + // If field is not touched, it either "empty" or has initial input + // If async field optional, then empty state is valid + // If it has initial value, in general it's from a server, hence valid + // If it's not from server and sync validator returned OK() but value is invalid, + // it should be rejected by the server on submit anyway + // So it doesn't worth to do 2+ requests on submission + let validator = [%e + Field.Field(name) + |> E.field(~of_="validators", ~loc) + ]; + `Result(validator.validate(input)); + | Dirty(result, _) => + // This field was updated by user so all its validators already run + `Result(result) + }, + Shown, + ); + } + } + ), + ); + let validating_cases = + scheme + |> List.fold_left( + (acc, entry: Scheme.entry) => + switch (entry) { + | Field({validator: SyncValidator(_)}) => acc + | Field({name, validator: AsyncValidator(_)}) => [ + Exp.case( + Pat.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name: name'}) when name == name' => [%pat? + (`Validating(_), _) + ] + | Field(_) => [%pat? (_, _)] + } + ), + ), + [%expr None], + ), + ...acc, + ] + }, + [], + ); + + let ok_case = + Exp.case( + Pat.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name, validator: SyncValidator(_)}) => [%pat? + ( + [%p + Pat.alias( + Pat.construct( + ~attrs=[explicit_arity(~loc)], + Lident("Ok") |> lid(~loc), + Some( + Pat.tuple([Pat.var(name |> str(~loc))]), + ), + ), + Field.Field(name) |> field_result |> str(~loc), + ) + ], + [%p + Pat.var( + Field.Field(name) + |> field_result_visibility + |> str(~loc), + ) + ], + ) + ] + | Field({name, validator: AsyncValidator(_)}) => [%pat? + ( + [%p + Pat.variant( + ~attrs=[explicit_arity(~loc)], + "Result", + Some( + Pat.alias( + Pat.construct( + ~attrs=[explicit_arity(~loc)], + Lident("Ok") |> lid(~loc), + Some( + Pat.tuple([ + Pat.var(name |> str(~loc)), + ]), + ), + ), + Field.Field(name) + |> field_result + |> str(~loc), + ), + ), + ) + ], + [%p + Pat.var( + Field.Field(name) + |> field_result_visibility + |> str(~loc), + ) + ], + ) + ] + } + ), + ), + [%expr + Some( + Valid({ + output: [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Lident(name) |> lid(~loc), + Exp.ident(Lident(name) |> lid(~loc)), + ) + } + ), + None, + ) + ], + fieldsStatuses: [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Lident(name) |> lid(~loc), + [%expr + Dirty( + [%e + Exp.ident( + Lident( + Field.Field(name) |> field_result, + ) + |> lid(~loc), + ) + ], + [%e + Exp.ident( + Lident( + Field.Field(name) + |> field_result_visibility, + ) + |> lid(~loc), + ) + ], + ) + ], + ) + } + ), + None, + ) + ], + }), + ) + ], + ); + + let error_case = + Exp.case( + Pat.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + Pat.tuple([ + Pat.var( + Field.Field(name) |> field_result |> str(~loc), + ), + Pat.var( + Field.Field(name) + |> field_result_visibility + |> str(~loc), + ), + ]) + } + ), + ), + [%expr + Some( + Invalid({ + fieldsStatuses: [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name, validator: SyncValidator(_)}) => ( + Lident(name) |> lid(~loc), + [%expr + Dirty( + [%e + Exp.ident( + Lident( + Field.Field(name) |> field_result, + ) + |> lid(~loc), + ) + ], + [%e + Exp.ident( + Lident( + Field.Field(name) + |> field_result_visibility, + ) + |> lid(~loc), + ) + ], + ) + ], + ) + | Field({name, validator: AsyncValidator(_)}) => ( + Lident(name) |> lid(~loc), + switch%expr ( + [%e + Exp.ident( + Lident( + Field.Field(name) |> field_result, + ) + |> lid(~loc), + ) + ] + ) { + | `Validating(x) => Validating(x) + | `Result(result) => + Dirty( + result, + [%e + Exp.ident( + Lident( + Field.Field(name) + |> field_result_visibility, + ) + |> lid(~loc), + ) + ], + ) + }, + ) + } + ), + None, + ) + ], + }), + ) + ], + ); + + Exp.match( + match_values, + List.append(validating_cases, [ok_case, error_case]), + ); + }; + } + ]; +}; diff --git a/lib/ppx/Form_ValidateFormFn_Sync.re b/lib/ppx/Form_ValidateFormFn_Sync.re new file mode 100644 index 00000000..0a45d087 --- /dev/null +++ b/lib/ppx/Form_ValidateFormFn_Sync.re @@ -0,0 +1,217 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => { + let field_result = x => (x |> Field.to_camelized_string) ++ "Result"; + let field_result_visibility = x => + (x |> Field.to_camelized_string) ++ "ResultVisibility"; + + [%stri + let validateForm = + ( + input: input, + ~validators: validators, + ~fieldsStatuses: fieldsStatuses, + ) + : formValidationResult(output, fieldsStatuses) => { + %e + { + let match_values = + Exp.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({ + name, + validator: + SyncValidator( + Ok(Required | Optional(Some(_))) | Error (), + ), + }) => + %expr + { + ( + switch ( + [%e + Field.Field(name) + |> E.field(~of_="fieldsStatuses", ~loc) + ] + ) { + | Pristine => + let validator = [%e + Field.Field(name) + |> E.field(~of_="validators", ~loc) + ]; + validator.validate(input); + | Dirty(result, _) => result + }, + Shown, + ); + } + | Field({ + name, + validator: SyncValidator(Ok(Optional(None))), + }) => + %expr + ( + Ok( + [%e Field.Field(name) |> E.field(~of_="input", ~loc)], + ), + Hidden, + ) + | Field({name, validator: AsyncValidator(_)}) => + failwith( + "Form that supposed to be without async validators has one. Please, file an issue with yoour use-case.", + ) + } + ), + ); + + let ok_case = + Exp.case( + Pat.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + Pat.tuple([ + Pat.alias( + Pat.construct( + ~attrs=[explicit_arity(~loc)], + Lident("Ok") |> lid(~loc), + Some(Pat.tuple([Pat.var(name |> str(~loc))])), + ), + Field.Field(name) |> field_result |> str(~loc), + ), + Pat.var( + Field.Field(name) + |> field_result_visibility + |> str(~loc), + ), + ]) + } + ), + ), + [%expr + Valid({ + output: [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Lident(name) |> lid(~loc), + Exp.ident(Lident(name) |> lid(~loc)), + ) + } + ), + None, + ) + ], + fieldsStatuses: [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Lident(name) |> lid(~loc), + [%expr + Dirty( + [%e + Exp.ident( + Lident( + Field.Field(name) |> field_result, + ) + |> lid(~loc), + ) + ], + [%e + Exp.ident( + Lident( + Field.Field(name) + |> field_result_visibility, + ) + |> lid(~loc), + ) + ], + ) + ], + ) + } + ), + None, + ) + ], + }) + ], + ); + + let error_case = + Exp.case( + Pat.tuple( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => + Pat.tuple([ + Pat.var( + Field.Field(name) |> field_result |> str(~loc), + ), + Pat.var( + Field.Field(name) + |> field_result_visibility + |> str(~loc), + ), + ]) + } + ), + ), + [%expr + Invalid({ + fieldsStatuses: [%e + Exp.record( + scheme + |> List.map((entry: Scheme.entry) => + switch (entry) { + | Field({name}) => ( + Lident(name) |> lid(~loc), + [%expr + Dirty( + [%e + Exp.ident( + Lident( + Field.Field(name) |> field_result, + ) + |> lid(~loc), + ) + ], + [%e + Exp.ident( + Lident( + Field.Field(name) + |> field_result_visibility, + ) + |> lid(~loc), + ) + ], + ) + ], + ) + } + ), + None, + ) + ], + }) + ], + ); + + Exp.match(match_values, [ok_case, error_case]); + }; + } + ]; +}; diff --git a/lib/ppx/Form_ValidatorsRecord.re b/lib/ppx/Form_ValidatorsRecord.re new file mode 100644 index 00000000..d1c061a8 --- /dev/null +++ b/lib/ppx/Form_ValidatorsRecord.re @@ -0,0 +1,105 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +// What we need to do here: +// 1. Update values of optional validators +// 2. Wrap async validators that run on change with debouncer +// 3. Don't touch unknown, let compiler do its job +let ast = (scheme: Scheme.t, value_binding: value_binding) => { + let adjust = (fields: ValidatorsRecord.raw_validators) => + fields + |> List.map(((lid, expr)) => + switch (lid) { + | {txt: Lident(field)} => + let entry = + scheme + |> List.find_opt( + fun + | Scheme.Field({name}) => name == field, + ); + switch (entry) { + | Some(Field({validator})) => + switch (validator) { + | SyncValidator(Ok(Required)) => (lid, expr) + | SyncValidator(Ok(Optional(Some(expr)))) => (lid, expr) + | SyncValidator(Ok(Optional(None))) => + let loc = expr.pexp_loc; + (lid, [%expr ()]); + | SyncValidator(Error ()) => (lid, expr) + | AsyncValidator({mode: OnBlur}) => (lid, expr) + | AsyncValidator({mode: OnChange}) => (lid, expr) // TODO: Wrap in debouncer + } + | None => (lid, expr) + }; + | _ => (lid, expr) + } + ); + { + ...value_binding, + pvb_expr: + // TODO: We're doing double work here since we can save all this stuff + // on the first pass while building up metadata, we can optimize it later + switch (value_binding.pvb_expr) { + | { + pexp_desc: Pexp_record(fields, None), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + } => { + pexp_desc: + Pexp_constraint( + { + pexp_desc: Pexp_record(fields |> adjust, None), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + }, + { + let loc = pexp_loc; + [%type: validators]; + }, + ), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + } + | { + pexp_desc: + Pexp_constraint( + { + pexp_desc: Pexp_record(fields, None), + pexp_loc: pexp_loc', + pexp_loc_stack: pexp_loc_stack', + pexp_attributes: pexp_attributes', + }, + typ, + ), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + } => { + pexp_desc: + Pexp_constraint( + { + pexp_desc: Pexp_record(fields |> adjust, None), + pexp_loc: pexp_loc', + pexp_loc_stack: pexp_loc_stack', + pexp_attributes: pexp_attributes', + }, + typ, + ), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + } + | _ => + failwith( + "Validators record doesn't seem like a record. Please, file an issue with your use-case.", + ) + }, + }; +}; diff --git a/lib/ppx/Form_ValidatorsType.re b/lib/ppx/Form_ValidatorsType.re new file mode 100644 index 00000000..58a5b9ce --- /dev/null +++ b/lib/ppx/Form_ValidatorsType.re @@ -0,0 +1,32 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +let ast = (~loc, scheme: Scheme.t) => { + scheme + |> T.record_of_fields( + ~name="validators", ~loc, ~typ=(~validator, ~output_type) => + switch (validator) { + | SyncValidator(Ok(Required)) + | SyncValidator(Ok(Optional(Some(_)))) + | SyncValidator(Error ()) => [%type: + singleValueValidator( + input, + [%t output_type |> FieldType.unpack], + message, + ) + ] + | SyncValidator(Ok(Optional(None))) => [%type: unit] + | AsyncValidator(_) => [%type: + Async.singleValueValidator( + input, + [%t output_type |> FieldType.unpack], + message, + ) + ] + } + ); +}; diff --git a/lib/ppx/Meta.re b/lib/ppx/Meta.re index 5fdd028f..ec1f40c6 100644 --- a/lib/ppx/Meta.re +++ b/lib/ppx/Meta.re @@ -3,28 +3,37 @@ open Ast; open Ppxlib; module Field = { - module T: {type t;} = { - type t = string; - }; + type t = + | Field(string); - type t = T.t; - external to_string: t => string = "%identity"; - external from_string: string => t = "%identity"; + let make = (label: label_declaration) => Field(label.pld_name.txt); - let make = (label: label_declaration) => label.pld_name.txt |> from_string; + let to_camelized_string = + fun + | Field(field) => field; - let to_capitalized_string = (field: t) => - field |> to_string |> String.capitalize_ascii; + let to_capitalized_string = + fun + | Field(field) => field |> String.capitalize_ascii; - let eq = (x1, x2) => to_string(x1) == to_string(x2); - let cmp = (x1, x2) => compare(x1 |> to_string, x2 |> to_string); + let eq = (x1, x2) => + switch (x1, x2) { + | (Field(x1), Field(x2)) => x1 == x2 + }; + + let cmp = (x1, x2) => + switch (x1, x2) { + | (Field(x1), Field(x2)) => compare(x1, x2) + }; let update_action = x => "Update" ++ (x |> to_capitalized_string) ++ "Field"; let blur_action = x => "Blur" ++ (x |> to_capitalized_string) ++ "Field"; + let apply_async_result_action = x => + "ApplyAsyncResultFor" ++ (x |> to_capitalized_string) ++ "Field"; let update_fn = x => "update" ++ (x |> to_capitalized_string); let blur_fn = x => "blur" ++ (x |> to_capitalized_string); - let result_fn = x => (x |> to_string) ++ "Result"; + let result_fn = x => (x |> to_camelized_string) ++ "Result"; }; module FieldType = { @@ -64,63 +73,48 @@ module FieldType = { let eq = (x1: t, x2: t) => eq(x1 |> unpack, x2 |> unpack); }; -module FieldDeps = { - type unvalidated_dep = [ | `Field(string, Location.t)]; +module FieldOptionality = { + type t = + | OptionType + | StringType + | OptionStringType; +}; - type error = - | DepsParseError(Location.t) - | DepNotFound(unvalidated_dep) - | DepOfItself(unvalidated_dep) - | DepDuplicate(unvalidated_dep); +module AsyncMode = { + type t = + | OnChange + | OnBlur; - let from_attributes = (attributes: list(attribute)) => { - let deps_attr = - attributes - |> List.find_opt(attr => - switch (attr) { - | {attr_name: {txt: "field.deps"}} => true - | _ => false - } - ); - switch (deps_attr) { - | None => Ok([]) - | Some({ - attr_payload: PStr([{pstr_desc: Pstr_eval(exp, _)}]), - attr_loc, - }) => - switch (exp) { - | {pexp_desc: Pexp_ident({txt: Lident(dep), loc})} => - Ok([`Field((dep, loc))]) - | {pexp_desc: Pexp_tuple(exps)} => - exps - |> List.fold_left( - (res, exp) => - switch (res, exp) { - | (Error(loc), _) => Error(loc) - | ( - Ok(deps), - {pexp_desc: Pexp_ident({txt: Lident(dep), loc})}, - ) => - Ok([`Field((dep, loc)), ...deps]) - | (Ok(_), {pexp_loc}) => Error(DepsParseError(pexp_loc)) - }, - Ok([]), - ) - | {pexp_loc} => Error(DepsParseError(pexp_loc)) - } - | Some({attr_loc}) => Error(DepsParseError(attr_loc)) - }; - }; + let default = OnChange; }; -module FieldSpec = { - type t = { - id: Field.t, - input_type: FieldType.t, - output_type: FieldType.t, - validator: [ | `Required | `Optional], - deps: list(Field.t), - }; +module ValidatorsRecord = { + type t = {entries: raw_validators} + and raw_validators = list((loc(Longident.t), expression)); +}; + +module FieldValidator = { + type t = + | SyncValidator(result(sync, unit)) + | AsyncValidator({ + mode: AsyncMode.t, + optionality: option(FieldOptionality.t), + }) + and sync = + | Required + | Optional(option(expression)); +}; + +module Scheme = { + type t = list(entry) + and entry = + | Field({ + name: string, + input_type: FieldType.t, + output_type: FieldType.t, + validator: FieldValidator.t, + deps: list(Field.t), + }); }; module InputType = { @@ -179,16 +173,264 @@ module SubmissionErrorType = { let default = (~loc) => [%stri type submissionError = unit] |> pack; }; +module FieldOptionalityParser = { + let parse = (typ: FieldType.t): option(FieldOptionality.t) => + switch (typ |> FieldType.unpack) { + | {ptyp_desc: Ptyp_constr({txt: Lident("string")}, [])} => + Some(StringType) + | { + ptyp_desc: + Ptyp_constr( + {txt: Lident("option")}, + [{ptyp_desc: Ptyp_constr({txt: Lident("string")}, [])}], + ), + } => + Some(OptionStringType) + | {ptyp_desc: Ptyp_constr({txt: Lident("option")}, _)} => + Some(OptionType) + | _ => None + }; +}; + +module AsyncFieldParser = { + type error = + | InvalidPayload(Location.t) + | InvalidAsyncMode(Location.t); + + let parse = (attributes: list(attribute)) => { + let async_attr = + attributes + |> List.find_opt(attr => + switch (attr) { + | {attr_name: {txt: "field.async"}} => true + | _ => false + } + ); + switch (async_attr) { + | None => Ok(None) + | Some({attr_payload: PStr([]), attr_loc}) => + Ok(Some(AsyncMode.default)) + | Some({ + attr_payload: + PStr([ + { + pstr_desc: + Pstr_eval( + { + pexp_desc: + Pexp_record( + [ + ( + {txt: Lident("mode")}, + { + pexp_desc: + Pexp_construct( + {txt: Lident(mode), loc}, + None, + ), + }, + ), + ], + None, + ), + }, + _, + ), + }, + ]), + attr_loc, + }) => + switch (mode) { + | "OnChange" => Ok(Some(OnChange)) + | "OnBlur" => Ok(Some(OnBlur)) + | _ => Error(InvalidAsyncMode(loc)) + } + | Some({attr_payload: PStr([{pstr_loc}])}) => + Error(InvalidPayload(pstr_loc)) + | Some({attr_loc}) => Error(InvalidPayload(attr_loc)) + }; + }; +}; + +module FieldDepsParser = { + type unvalidated_dep = [ | `Field(string, Location.t)]; + + type error = + | DepsParseError(Location.t) + | DepNotFound(unvalidated_dep) + | DepOfItself(unvalidated_dep) + | DepDuplicate(unvalidated_dep); + + let parse = (attributes: list(attribute)) => { + let deps_attr = + attributes + |> List.find_opt(attr => + switch (attr) { + | {attr_name: {txt: "field.deps"}} => true + | _ => false + } + ); + switch (deps_attr) { + | None => Ok([]) + | Some({ + attr_payload: PStr([{pstr_desc: Pstr_eval(exp, _)}]), + attr_loc, + }) => + switch (exp) { + | {pexp_desc: Pexp_ident({txt: Lident(dep), loc})} => + Ok([`Field((dep, loc))]) + | {pexp_desc: Pexp_tuple(exps)} => + exps + |> List.fold_left( + (res, exp) => + switch (res, exp) { + | (Error(loc), _) => Error(loc) + | ( + Ok(deps), + {pexp_desc: Pexp_ident({txt: Lident(dep), loc})}, + ) => + Ok([`Field((dep, loc)), ...deps]) + | (Ok(_), {pexp_loc}) => Error(DepsParseError(pexp_loc)) + }, + Ok([]), + ) + | {pexp_loc} => Error(DepsParseError(pexp_loc)) + } + | Some({attr_loc}) => Error(DepsParseError(attr_loc)) + }; + }; + + let validate = + ( + fields: + list( + ( + Field.t, + FieldType.t, + option(AsyncMode.t), + list(unvalidated_dep), + ), + ), + ) => + fields + |> List.fold_left( + (res, (field: Field.t, _, _, deps)) => + switch (res) { + | Error(error) => Error(error) + | Ok(_) => + deps + |> List.fold_left( + (res, dep) => + switch (res, dep) { + | (Error(error), _) => Error(error) + | (Ok (), `Field(dep_name, loc)) => + switch ( + deps + |> List.find_all(dep' => + switch (dep') { + | `Field(dep', _) => dep' == dep_name + } + ) + |> List.length + ) { + | 0 + | 1 => + switch ( + fields + |> List.find_opt(((field: Field.t, _, _, _)) => + switch (field) { + | Field(field) => field == dep_name + } + ), + field, + ) { + | (None, _) => Error(DepNotFound(dep)) + | (Some(_), Field(field)) => + dep_name != field ? Ok() : Error(DepOfItself(dep)) + } + | _ => Error(DepDuplicate(dep)) + } + }, + Ok(), + ) + }, + Ok(), + ); +}; + module InputTypeParser = { type result = Pervasives.result(ok, error) and ok = { - fields: list((Field.t, FieldType.t, list(FieldDeps.unvalidated_dep))), + fields, structure_item: InputType.t, } + and fields = + list( + ( + Field.t, + FieldType.t, + option(AsyncMode.t), + list(FieldDepsParser.unvalidated_dep), + ), + ) and error = | NotFound | NotRecord(Location.t) - | InvalidFieldDeps(FieldDeps.error); + | InvalidAsyncField(AsyncFieldParser.error) + | InvalidFieldDeps(FieldDepsParser.error); + + let parse = (~decl, ~rec_flag, ~loc, fields) => { + let fields = + List.fold_right( + (field, res) => + switch ( + res, + field.pld_type.ptyp_attributes |> AsyncFieldParser.parse, + field.pld_type.ptyp_attributes |> FieldDepsParser.parse, + ) { + | (Ok(fields), Ok(async), Ok(deps)) => + Ok([ + ( + field |> Field.make, + field.pld_type |> FieldType.make, + async, + deps, + ), + ...fields, + ]) + | (Error(error), _, _) => Error(error) + | (_, Error(error), _) => Error(InvalidAsyncField(error)) + | (_, _, Error(error)) => Error(InvalidFieldDeps(error)) + }, + fields, + Ok([]), + ); + switch (fields) { + | Error(error) => Error(error) + | Ok(fields) => + Ok({fields, structure_item: decl |> InputType.make(~loc, ~rec_flag)}) + }; + }; + + let in_deps_of = (fields: fields, field: Field.t) => + fields + |> List.find_opt(((field', _, _, deps)) => + if (field |> Field.eq(field')) { + false; + } else { + switch ( + deps + |> List.find_opt(dep => + switch (dep, field) { + | (`Field(dep, _), Field(field)) => dep == field + } + ) + ) { + | Some(_) => true + | None => false + }; + } + ); }; module OutputTypeParser = { @@ -207,20 +449,205 @@ module OutputTypeParser = { alias: string, loc: Location.t, }); + + let parse_as_record = (~decl, ~rec_flag, ~loc, fields) => + Record({ + fields: + List.fold_right( + (field, acc) => + [ + ( + field |> Field.make, + field.pld_type |> FieldType.make, + field.pld_loc, + ), + ...acc, + ], + fields, + [], + ), + loc, + structure_item: decl |> OutputType.make(~loc, ~rec_flag), + }); + + let parse_as_alias = (~decl, ~rec_flag, ~loc) => + AliasOfInput(decl |> OutputType.make(~loc, ~rec_flag)); +}; + +module ValidatorsRecordParser = { + type result = Pervasives.result(ValidatorsRecord.t, error) + and error = + | NotFound + | NotRecord(Location.t) + | BadTypeAnnotation(Location.t) + | ValidatorError( + [ + | `BadRequiredValidator( + Field.t, + [ | `Some(Location.t) | `None(Location.t)], + [ + | `IncludedInDeps(Field.t) + | `DifferentIO(FieldType.t, FieldType.t) + ], + ) + ], + ) + | RecordParseError(Location.t); + + let have_validators = (values: list(value_binding)) => + values + |> List.exists( + fun + | {pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}} => true + | _ => false, + ); + + let parse = (structure_item: structure_item): result => { + let fields_from_expr = + (expr: expression): Pervasives.result(ValidatorsRecord.t, error) => + switch (expr) { + | {pexp_desc: Pexp_record(fields, None)} => Ok({entries: fields}) + | {pexp_loc} => Error(NotRecord(pexp_loc)) + }; + + switch (structure_item) { + | { + pstr_loc, + pstr_desc: + Pstr_value( + rec_flag, + [ + { + pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}, + pvb_expr: { + pexp_desc: + Pexp_constraint( + {pexp_loc} as expr, + {ptyp_desc: Ptyp_constr(typ, args), ptyp_loc}, + ), + }, + }, + ], + ), + } => + switch (typ, args) { + | ({txt: Lident("validators")}, []) => expr |> fields_from_expr + | ({txt: _}, _) => Error(BadTypeAnnotation(ptyp_loc)) + } + | { + pstr_desc: + Pstr_value( + rec_flag, + [ + { + pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}, + pvb_expr: {pexp_loc} as expr, + }, + ], + ), + } => + expr |> fields_from_expr + | {pstr_loc} => Error(RecordParseError(pstr_loc)) + }; + }; + + let find = (field: Field.t, validators: ValidatorsRecord.raw_validators) => + validators + |> List.find_opt(validator => + switch (field, validator) { + | (Field(field), ({txt: Lident(field')}, _)) => field == field' + | (Field(_), ({txt: _}, _)) => false + } + ); + + let required = (field: Field.t, validators: ValidatorsRecord.raw_validators) => { + switch (field, validators |> find(field)) { + | (Field(field), Some((_, {pexp_desc: Pexp_record(_)}))) => Ok() + | ( + Field(field), + Some(( + _, + { + pexp_desc: + Pexp_construct( + {txt: Lident("Some")}, + Some({pexp_desc: Pexp_record(_)}), + ), + pexp_loc, + }, + )), + ) => + Error(`Some(pexp_loc)) + | ( + Field(field), + Some(( + _, + { + pexp_desc: Pexp_construct({txt: Lident("None")}, None), + pexp_loc, + }, + )), + ) => + Error(`None(pexp_loc)) + // Don't know what it is, let compiler do the job + | (Field(field), Some(_)) => Error(`BadValue) + // Validator doesn't exist, delegating to compiler + | (Field(field), None) => Error(`NotFound) + }; + }; + + let optional = (field: Field.t, validators: ValidatorsRecord.raw_validators) => { + switch (field, validators |> find(field)) { + // This can be just record + | (Field(field), Some((_, {pexp_desc: Pexp_record(_)} as expr))) => + Ok(Some(expr)) + // Or Some(record) + | ( + Field(field), + Some(( + _, + { + pexp_desc: + Pexp_construct( + {txt: Lident("Some")}, + Some({pexp_desc: Pexp_record(_)} as expr), + ), + }, + )), + ) => + Ok(Some(expr)) + // Or None + | ( + Field(field), + Some(( + _, + {pexp_desc: Pexp_construct({txt: Lident("None")}, None)}, + )), + ) => + Ok(None) + // Don't know what it is, let compiler do the job + | (Field(field), Some(_)) => Error(`BadValue) + // Validator doesn't exist, delegating to compiler + | (Field(field), None) => Error(`NotFound) + }; + }; }; -module Data = { +module Metadata = { type t = { - fields: list(FieldSpec.t), + scheme: Scheme.t, + async: bool, // meh, it should be variant: Sync(_) | Async(_) input_type: InputType.t, output_type: OutputType.t, message_type: MessageType.t, submission_error_type: SubmissionErrorType.t, + validators_record: ValidatorsRecord.t, }; type error = | InputTypeParseError(InputTypeParser.error) | OutputTypeParseError(OutputTypeParser.error) + | ValidatorsRecordParseError(ValidatorsRecordParser.error) | IOMismatch(io_mismatch) and io_mismatch = | InputFieldsNotInOutput({ @@ -242,6 +669,7 @@ module Data = { let message_type: ref(option(MessageType.t)) = ref(None); let submission_error_type: ref(option(SubmissionErrorType.t)) = ref(None); + let validators_record: ref(option(structure_item)) = ref(None); structure |> List.iter( @@ -258,41 +686,12 @@ module Data = { } as decl => input_parsing_result := Some( - { - let fields = - List.fold_right( - (field, res) => - switch ( - res, - field.pld_type.ptyp_attributes - |> FieldDeps.from_attributes, - ) { - | (Ok(fields), Ok(deps)) => - Ok([ - ( - field |> Field.make, - field.pld_type |> FieldType.make, - deps, - ), - ...fields, - ]) - | (Error(error), _) - | (_, Error(error)) => Error(error) - }, - fields, - Ok([]), - ); - switch (fields) { - | Error(error) => Error(InvalidFieldDeps(error)) - | Ok(fields) => - Ok({ - fields, - structure_item: - decl - |> InputType.make(~loc=ptype_loc, ~rec_flag), - }) - }; - }, + fields + |> InputTypeParser.parse( + ~decl, + ~rec_flag, + ~loc=ptype_loc, + ), ) | {ptype_name: {txt: "input"}, ptype_loc} => input_parsing_result := @@ -307,26 +706,12 @@ module Data = { output_parsing_result := Some( Ok( - Record({ - fields: - List.fold_right( - (field, acc) => - [ - ( - field |> Field.make, - field.pld_type |> FieldType.make, - field.pld_loc, - ), - ...acc, - ], - fields, - [], - ), - loc: ptype_loc, - structure_item: - decl - |> OutputType.make(~loc=ptype_loc, ~rec_flag), - }), + fields + |> OutputTypeParser.parse_as_record( + ~decl, + ~rec_flag, + ~loc=ptype_loc, + ), ), ) | { @@ -342,8 +727,10 @@ module Data = { output_parsing_result := Some( Ok( - AliasOfInput( - decl |> OutputType.make(~loc=ptype_loc, ~rec_flag), + OutputTypeParser.parse_as_alias( + ~decl, + ~rec_flag, + ~loc=ptype_loc, ), ), ) @@ -391,203 +778,362 @@ module Data = { | _ => (), ); } + // Validators + | {pstr_desc: Pstr_value(rec_flag, values)} as structure_item + when values |> ValidatorsRecordParser.have_validators => { + validators_record := Some(structure_item); + } | _ => (), ); - switch (input_parsing_result^, output_parsing_result^) { - | (Some(Error(error)), _) => Error(InputTypeParseError(error)) - | (None, _) => Error(InputTypeParseError(NotFound)) - | (_, Some(Error(error))) => Error(OutputTypeParseError(error)) - | (_, None) => Error(OutputTypeParseError(NotFound)) - | (Some(Ok(input_data)), Some(Ok(output_result))) => - let deps_validity = - input_data.fields - |> List.fold_left( - (res, (field, _, deps)) => - switch (res) { - | Error(error) => Error(error) - | Ok(_) => - deps - |> List.fold_left( - (res, dep) => - switch (res, dep) { - | (Error(error), _) => Error(error) - | (Ok (), `Field(dep_name, loc)) => - switch ( - deps - |> List.find_all(dep' => - switch (dep') { - | `Field(dep', _) => dep' == dep_name - } - ) - |> List.length - ) { - | 0 - | 1 => - switch ( - input_data.fields - |> List.find_opt(((field, _, _)) => - field |> Field.to_string == dep_name - ) - ) { - | None => Error(FieldDeps.DepNotFound(dep)) - | Some(_) - when dep_name == (field |> Field.to_string) => - Error(FieldDeps.DepOfItself(dep)) - | Some(_) => Ok() - } - | _ => Error(FieldDeps.DepDuplicate(dep)) - } - }, - Ok(), - ) - }, - Ok(), - ); - switch (deps_validity) { + switch (input_parsing_result^, output_parsing_result^, validators_record^) { + | (Some(Error(error)), _, _) => Error(InputTypeParseError(error)) + | (None, _, _) => Error(InputTypeParseError(NotFound)) + | (_, Some(Error(error)), _) => Error(OutputTypeParseError(error)) + | (_, None, _) => Error(OutputTypeParseError(NotFound)) + | (_, _, None) => Error(ValidatorsRecordParseError(NotFound)) + | ( + Some(Ok(input_data)), + Some(Ok(output_result)), + Some(validators_record), + ) => + switch (input_data.fields |> FieldDepsParser.validate) { | Error(error) => Error(InputTypeParseError(InvalidFieldDeps(error))) | Ok () => - let fields = - switch (output_result) { - | AliasOfInput(_) => - Ok( + switch (validators_record |> ValidatorsRecordParser.parse) { + | Error(error) => Error(ValidatorsRecordParseError(error)) + | Ok(validators) => + let scheme: result(Scheme.t, error) = + switch (output_result) { + | AliasOfInput(_) => input_data.fields - |> List.map(((field, input_type, deps)) => - FieldSpec.{ - id: field, - input_type, - output_type: input_type, - validator: `Optional, - deps: - deps - |> List.map( - fun - | `Field(dep, _) => dep |> Field.from_string, - ), - } - ), - ) - | Record({fields: output_fields, loc: output_loc}) => - let ( - matched_fields, - input_fields_not_in_output, - output_fields_not_in_input, - ) = - List.fold_right( - ( - (input_field, input_field_type, input_field_deps), + |> List.fold_left( + (res, (field, input_type, async, deps)) => { + switch (res) { + | Error(error) => Error(error) + | Ok(scheme) => + let validator: result(FieldValidator.t, error) = + switch (async) { + | None => + switch ( + field + |> InputTypeParser.in_deps_of(input_data.fields) + ) { + | Some((in_deps_of_field, _, _, _)) => + switch ( + validators.entries + |> ValidatorsRecordParser.required(field) + ) { + | Ok () => Ok(SyncValidator(Ok(Required))) + | Error(`NotFound | `BadValue) => + // Proceeding here since compiler + // would give more insightful error message + Ok(SyncValidator(Error())) + | Error(`Some(_) as reason | `None(_) as reason) => + // In this case we can give more insights (hopefully) + // on how to fix this error + Error( + ValidatorsRecordParseError( + ValidatorError( + `BadRequiredValidator(( + field, + reason, + `IncludedInDeps(in_deps_of_field), + )), + ), + ), + ) + } + | None => + switch ( + validators.entries + |> ValidatorsRecordParser.optional(field) + ) { + | Ok(res) => + Ok(SyncValidator(Ok(Optional(res)))) + | Error(`NotFound | `BadValue) => + // Proceeding here since compiler + // would give more insightful error message + Ok(SyncValidator(Error())) + } + } + | Some(mode) => + Ok( + AsyncValidator({ + mode, + optionality: + input_type |> FieldOptionalityParser.parse, + }), + ) + }; + switch (field, validator) { + | (Field(field), Ok(validator)) => + Ok([ + Scheme.Field({ + name: field, + input_type, + output_type: input_type, + validator, + deps: + deps + |> List.map( + fun + | `Field(dep, _) => Field.Field(dep), + ), + }), + ...scheme, + ]) + | (_, Error(error)) => Error(error) + }; + } + }, + Ok([]), + ) + | Record({fields: output_fields, loc: output_loc}) => + let ( + matched_fields, + input_fields_not_in_output, + output_fields_not_in_input, + ) = + List.fold_right( ( - matched_fields, - input_fields_not_in_output, - output_fields_not_in_input, - ), - ) => { - let output_field = - output_fields - |> List.find_opt(((output_field, _, _)) => - input_field |> Field.eq(output_field) - ); - switch (output_field) { - | None => ( + ( + input_field, + input_field_type, + input_field_async_mode, + input_field_deps, + ), + ( matched_fields, - [input_field, ...input_fields_not_in_output], + input_fields_not_in_output, output_fields_not_in_input, - ) - | Some((output_field, output_field_type, _)) => ( - [ - FieldSpec.{ - id: input_field, - input_type: input_field_type, - output_type: output_field_type, - validator: + ), + ) => { + let output_field = + output_fields + |> List.find_opt(((output_field, _, _)) => + input_field |> Field.eq(output_field) + ); + switch (matched_fields, output_field) { + | (_, None) => ( + matched_fields, + [input_field, ...input_fields_not_in_output], + output_fields_not_in_input, + ) + | ( + Error(error), + Some((output_field, output_field_type, _)), + ) => ( + Error(error), + input_fields_not_in_output, + output_fields_not_in_input + |> List.filter(((output_field, _, _)) => + !(input_field |> Field.eq(output_field)) + ), + ) + + | ( + Ok(scheme), + Some((output_field, output_field_type, _)), + ) => + let validator: result(FieldValidator.t, error) = + switch (input_field_async_mode) { + | None => + switch ( + input_field + |> InputTypeParser.in_deps_of(input_data.fields) + ) { + | Some((in_deps_of_field, _, _, _)) => + switch ( + validators.entries + |> ValidatorsRecordParser.required(input_field) + ) { + | Ok () => Ok(SyncValidator(Ok(Required))) + | Error(`NotFound | `BadValue) => + // Proceeding here since compiler + // would give more insightful error message + Ok(SyncValidator(Error())) + | Error(`Some(_) as reason | `None(_) as reason) => + // In this case we can give more insights (hopefully) + // on how to fix this error + Error( + ValidatorsRecordParseError( + ValidatorError( + `BadRequiredValidator(( + input_field, + reason, + `IncludedInDeps(in_deps_of_field), + )), + ), + ), + ) + } + | None => if (FieldType.eq( input_field_type, output_field_type, )) { - `Optional; + switch ( + validators.entries + |> ValidatorsRecordParser.optional( + input_field, + ) + ) { + | Ok(res) => + Ok(SyncValidator(Ok(Optional(res)))) + | Error(`NotFound | `BadValue) => + // Proceeding here since compiler + // would give more insightful error message + Ok(SyncValidator(Error())) + }; } else { - `Required; - }, - deps: - input_field_deps - |> List.map( - fun - | `Field(dep, _) => dep |> Field.from_string, - ), + switch ( + validators.entries + |> ValidatorsRecordParser.required( + input_field, + ) + ) { + | Ok () => Ok(SyncValidator(Ok(Required))) + | Error(`NotFound | `BadValue) => + // Proceeding here since compiler + // would give more insightful error message + Ok(SyncValidator(Error())) + | Error(`Some(_) as reason | `None(_) as reason) => + // In this case we can give more insights (hopefully) + // on how to fix this error + Error( + ValidatorsRecordParseError( + ValidatorError( + `BadRequiredValidator(( + input_field, + reason, + `DifferentIO(( + input_field_type, + output_field_type, + )), + )), + ), + ), + ) + }; + } + } + | Some(mode) => + Ok( + AsyncValidator({ + mode, + optionality: + output_field_type + |> FieldOptionalityParser.parse, + }), + ) + }; + + ( + switch (input_field, validator) { + | (_, Error(error)) => Error(error) + | (Field(field), Ok(validator)) => + Ok([ + Scheme.Field({ + name: field, + input_type: input_field_type, + output_type: output_field_type, + validator, + deps: + input_field_deps + |> List.map( + fun + | `Field(dep, _) => Field.Field(dep), + ), + }), + ...scheme, + ]) }, - ...matched_fields, - ], + input_fields_not_in_output, + output_fields_not_in_input + |> List.filter(((output_field, _, _)) => + !(input_field |> Field.eq(output_field)) + ), + ); + }; + }, + input_data.fields, + (Ok([]), [], output_fields), + ); + switch (input_fields_not_in_output, output_fields_not_in_input) { + | ([], []) => matched_fields + | (input_fields_not_in_output, []) => + Error( + IOMismatch( + InputFieldsNotInOutput({ + fields: input_fields_not_in_output, + loc: output_loc, + }), + ), + ) + | ([], output_fields_not_in_input) => + Error( + IOMismatch( + OutputFieldsNotInInput({ + fields: + output_fields_not_in_input + |> List.map(((field, _, loc)) => (field, loc)), + }), + ), + ) + | (input_fields_not_in_output, output_fields_not_in_input) => + Error( + IOMismatch( + Both({ input_fields_not_in_output, - output_fields_not_in_input - |> List.filter(((output_field, _, _)) => - !(input_field |> Field.eq(output_field)) - ), - ) - }; - }, - input_data.fields, - ([], [], output_fields), - ); - switch (input_fields_not_in_output, output_fields_not_in_input) { - | ([], []) => Ok(matched_fields) - | (input_fields_not_in_output, []) => - Error( - IOMismatch( - InputFieldsNotInOutput({ - fields: input_fields_not_in_output, - loc: output_loc, - }), - ), - ) - | ([], output_fields_not_in_input) => - Error( - IOMismatch( - OutputFieldsNotInInput({ - fields: - output_fields_not_in_input - |> List.map(((field, _, loc)) => (field, loc)), - }), - ), - ) - | (input_fields_not_in_output, output_fields_not_in_input) => - Error( - IOMismatch( - Both({ - input_fields_not_in_output, - output_fields_not_in_input: - output_fields_not_in_input - |> List.map(((field, _, loc)) => (field, loc)), - loc: output_loc, - }), - ), - ) + output_fields_not_in_input: + output_fields_not_in_input + |> List.map(((field, _, loc)) => (field, loc)), + loc: output_loc, + }), + ), + ) + }; }; - }; - switch (fields) { - | Ok(fields) => - Ok({ - fields, - input_type: input_data.structure_item, - output_type: - switch (output_result) { - | AliasOfInput(structure_item) - | Record({structure_item}) => structure_item - }, - message_type: - switch (message_type^) { - | Some(x) => x - | None => MessageType.default(~loc=Location.none) - }, - submission_error_type: - switch (submission_error_type^) { - | Some(x) => x - | None => SubmissionErrorType.default(~loc=Location.none) - }, - }) - | Error(error) => Error(error) - }; - }; + switch (scheme) { + | Ok(scheme) => + Ok({ + scheme, + async: + // TODO: Quick and dirty. + // Scheme.t should be arapped in variant instead. + // Let's do base implementation first, + // then look into how to redesign it better + scheme + |> List.exists((entry: Scheme.entry) => + switch (entry) { + | Field({validator: AsyncValidator(_)}) => true + | Field({validator: SyncValidator(_)}) => false + } + ), + input_type: input_data.structure_item, + output_type: + switch (output_result) { + | AliasOfInput(structure_item) + | Record({structure_item}) => structure_item + }, + message_type: + switch (message_type^) { + | Some(x) => x + | None => MessageType.default(~loc=Location.none) + }, + submission_error_type: + switch (submission_error_type^) { + | Some(x) => x + | None => SubmissionErrorType.default(~loc=Location.none) + }, + validators_record: validators, + }) + | Error(error) => Error(error) + }; + } + } }; }; }; diff --git a/lib/ppx/Ppx.re b/lib/ppx/Ppx.re index 584039ac..f07e6c49 100644 --- a/lib/ppx/Ppx.re +++ b/lib/ppx/Ppx.re @@ -1,9 +1,13 @@ -// TODO: Async validation: `item: [@field.async] string` -// TODO: Collections: `items: [@field.collection] array(item)` -// TODO: Whole collection validation -// TODO: Field with deps validation -// TODO: Add/remove items from collections -// TODO: Reorder items in collections -// TODO: Strip attributes from input types +// TODO: [Genearl] Change `updateField` siganture so it accepts `input => input` instead of `input` +// TODO: [Async] Implement async callbacks: wrap validate function ast into function + debounce it in OnChange mode +// TODO: [Async] Set default eq function +// TODO: [Meta] Strip attributes from input types +// TODO: [Meta] Make output type optional +// TODO: [Meta] Revisit SyncValidator(Optional) parsing +// TODO: [Meta] Replace types injection with types replacement to keep things in module as defined by user +// TODO: [Collections] Collections: `items: [@field.collection] array(item)` +// TODO: [Collections] Whole collection validation +// TODO: [Collections] Add/remove items from collections +// TODO: [Collections] Reorder items in collections "formality" |> Ppxlib.Driver.register_transformation(~extensions=[Form.ext]); diff --git a/lib/src/Formality.re b/lib/src/Formality.re index a1d6a51c..a959402d 100644 --- a/lib/src/Formality.re +++ b/lib/src/Formality.re @@ -15,11 +15,6 @@ type fieldStatus('outputValue, 'message) = | Pristine | Dirty(result('outputValue, 'message), visibility); -type asyncFieldStatus('outputValue, 'message) = - | Pristine - | Dirty(result('outputValue, 'message), visibility) - | Validating; - type formStatus('submissionError) = | Editing | Submitting(option('submissionError)) @@ -30,6 +25,15 @@ type submissionStatus = | NeverSubmitted | AttemptedToSubmit; +let exposeFieldResult = + (fieldStatus: fieldStatus('outputValue, 'message)) + : option(result('outputValue, 'message)) => + switch (fieldStatus) { + | Pristine + | Dirty(_, Hidden) => None + | Dirty(result, Shown) => Some(result) + }; + type index = int; type singleValueValidator('input, 'outputValue, 'message) = { @@ -37,12 +41,6 @@ type singleValueValidator('input, 'outputValue, 'message) = { validate: 'input => result('outputValue, 'message), }; -type singleValueAsyncValidator('input, 'outputValue, 'message) = { - strategy, - validate: 'input => result('outputValue, 'message), - validateAsync: 'input => Js.Promise.t(result('outputValue, 'message)), -}; - type collectionValidator('input, 'message, 'fieldsValidators) = { collection: option('input => result(unit, 'message)), fields: 'fieldsValidators, @@ -53,19 +51,12 @@ type valueOfCollectionValidator('input, 'outputValue, 'message) = { validate: ('input, ~at: index) => result('outputValue, 'message), }; -type valueOfCollectionAsyncValidator('input, 'outputValue, 'message) = { - strategy, - validate: ('input, ~at: index) => result('outputValue, 'message), - validateAsync: - ('input, ~at: index) => Js.Promise.t(result('outputValue, 'message)), -}; - type formValidationResult('output, 'fieldsStatuses) = - | Ok({ + | Valid({ output: 'output, fieldsStatuses: 'fieldsStatuses, }) - | Error({fieldsStatuses: 'fieldsStatuses}); + | Invalid({fieldsStatuses: 'fieldsStatuses}); type submissionCallbacks('input, 'submissionError) = { notifyOnSuccess: option('input) => unit, @@ -74,6 +65,15 @@ type submissionCallbacks('input, 'submissionError) = { dismissSubmissionResult: unit => unit, }; +let validateFieldOnChangeWithoutValidator = + ( + ~fieldInput: 'outputValue, + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : 'statuses => { + Dirty(Ok(fieldInput), Hidden)->setStatus; +}; + let validateFieldOnChangeWithValidator = ( ~input: 'input, @@ -98,15 +98,6 @@ let validateFieldOnChangeWithValidator = }; }; -let validateFieldOnChangeWithoutValidator = - ( - ~fieldInput: 'outputValue, - ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, - ) - : 'statuses => { - Dirty(Ok(fieldInput), Hidden)->setStatus; -}; - let validateFieldDependencyOnChange = ( ~input: 'input, @@ -119,10 +110,22 @@ let validateFieldDependencyOnChange = | Pristine | Dirty(_, Hidden) => None | Dirty(_, Shown) => - Some(Dirty(validator.validate(input), Shown)->setStatus) + Dirty(validator.validate(input), Shown)->setStatus->Some }; }; +let validateFieldOnBlurWithoutValidator = + ( + ~fieldInput: 'outputValue, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : option('statuses) => + switch (fieldStatus) { + | Dirty(_, Shown | Hidden) => None + | Pristine => Dirty(Ok(fieldInput), Hidden)->setStatus->Some + }; + let validateFieldOnBlurWithValidator = ( ~input: 'input, @@ -138,31 +141,407 @@ let validateFieldOnBlurWithValidator = switch (validator.strategy) { | OnFirstChange | OnFirstSuccess - | OnSubmit => Some(Dirty(validator.validate(input), Hidden)->setStatus) + | OnSubmit => Dirty(validator.validate(input), Hidden)->setStatus->Some | OnFirstBlur | OnFirstSuccessOrFirstBlur => - Some(Dirty(validator.validate(input), Shown)->setStatus) + Dirty(validator.validate(input), Shown)->setStatus->Some } }; }; -let validateFieldOnBlurWithoutValidator = - ( - ~fieldInput: 'outputValue, - ~fieldStatus: fieldStatus('outputValue, 'message), - ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, - ) - : option('statuses) => - switch (fieldStatus) { - | Dirty(_, Shown | Hidden) => None - | Pristine => Some(Dirty(Ok(fieldInput), Hidden)->setStatus) +module Async = { + type fieldStatus('outputValue, 'message) = + | Pristine + | Dirty(result('outputValue, 'message), visibility) + | Validating('outputValue); + + type exposedFieldStatus('outputValue, 'message) = + | Validating('outputValue) + | Result(result('outputValue, 'message)); + + type singleValueValidator('input, 'outputValue, 'message) = { + strategy, + validate: 'input => result('outputValue, 'message), + validateAsync: + 'outputValue => Js.Promise.t(result('outputValue, 'message)), + eq: ('outputValue, 'outputValue) => bool, }; -let exposeFieldResult = - (fieldStatus: fieldStatus('outputValue, 'message)) - : option(result('outputValue, 'message)) => - switch (fieldStatus) { - | Pristine - | Dirty(_, Hidden) => None - | Dirty(result, Shown) => Some(result) + type valueOfCollectionValidator('input, 'outputValue, 'message) = { + strategy, + validate: ('input, ~at: index) => result('outputValue, 'message), + validateAsync: + 'outputValue => Js.Promise.t(result('outputValue, 'message)), + eq: ('outputValue, 'outputValue) => bool, + }; + + let exposeFieldResult = + (fieldStatus: fieldStatus('outputValue, 'message)) + : option(exposedFieldStatus('outputValue, 'message)) => + switch (fieldStatus) { + | Pristine + | Dirty(_, Hidden) => None + | Validating(x) => Some(Validating(x)) + | Dirty(result, Shown) => Some(Result(result)) + }; + + let validateFieldOnChangeInOnBlurMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(_) as result => Dirty(result, Hidden)->setStatus + | Error(_) as result => Dirty(result, Shown)->setStatus + } + | ( + OnFirstSuccess | OnFirstSuccessOrFirstBlur | OnFirstBlur | OnSubmit, + _, + NeverSubmitted, + ) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldOfOptionTypeOnChangeInOnBlurMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some(_)) as result => Dirty(result, Hidden)->setStatus + | Ok(None) as result + | Error(_) as result => Dirty(result, Shown)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(None) as result => Dirty(result, Shown)->setStatus + | Ok(Some(_)) as result + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; }; + + let validateFieldOfStringTypeOnChangeInOnBlurMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus(string, 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, string, 'message), + ~setStatus: fieldStatus(string, 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok("") as result + | Error(_) as result => Dirty(result, Shown)->setStatus + | Ok(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok("") as result => Dirty(result, Shown)->setStatus + | Ok(_) as result + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldOfOptionStringTypeOnChangeInOnBlurMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus(option(string), 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, option(string), 'message), + ~setStatus: fieldStatus(option(string), 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some("")) as result + | Ok(None) as result + | Error(_) as result => Dirty(result, Shown)->setStatus + | Ok(Some(_)) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some("")) as result + | Ok(None) as result => Dirty(result, Shown)->setStatus + | Ok(Some(_)) as result + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldOnChangeInOnChangeMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(x) => Validating(x)->setStatus + | Error(_) as result => Dirty(result, Shown)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(x) => Validating(x)->setStatus + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldOfOptionTypeOnChangeInOnChangeMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some(_) as x) => Validating(x)->setStatus + | Ok(None) as result + | Error(_) as result => Dirty(result, Shown)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some(_) as x) => Validating(x)->setStatus + | Ok(None) as result => Dirty(result, Shown)->setStatus + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldOfStringTypeOnChangeInOnChangeMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus(string, 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, string, 'message), + ~setStatus: fieldStatus(string, 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok("") as result + | Error(_) as result => Dirty(result, Shown)->setStatus + | Ok(x) => Validating(x)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok("") as result => Dirty(result, Shown)->setStatus + | Ok(x) => Validating(x)->setStatus + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldOfOptionStringTypeOnChangeInOnChangeMode = + ( + ~input: 'input, + ~fieldStatus: fieldStatus(option(string), 'message), + ~submissionStatus: submissionStatus, + ~validator: singleValueValidator('input, option(string), 'message), + ~setStatus: fieldStatus(option(string), 'message) => 'statuses, + ) + : 'statuses => { + switch (validator.strategy, fieldStatus, submissionStatus) { + | (_, Dirty(_, Shown), _) + | (_, _, AttemptedToSubmit) + | (OnFirstChange, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some("")) as result + | Ok(None) as result + | Error(_) as result => Dirty(result, Shown)->setStatus + | Ok(Some(_) as x) => Validating(x)->setStatus + } + | (OnFirstSuccess | OnFirstSuccessOrFirstBlur, _, NeverSubmitted) => + switch (validator.validate(input)) { + | Ok(Some("")) as result + | Ok(None) as result => Dirty(result, Shown)->setStatus + | Ok(Some(_) as x) => Validating(x)->setStatus + | Error(_) as result => Dirty(result, Hidden)->setStatus + } + | (OnFirstBlur | OnSubmit, _, NeverSubmitted) => + Dirty(validator.validate(input), Hidden)->setStatus + }; + }; + + let validateFieldDependencyOnChange = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : option('statuses) => { + switch (fieldStatus) { + | Pristine + | Validating(_) + | Dirty(_, Hidden) => None + | Dirty(_, Shown) => + Dirty(validator.validate(input), Shown)->setStatus->Some + }; + }; + + let validateFieldOnBlur = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : option('statuses) => { + switch (fieldStatus) { + | Validating(_) + | Dirty(_, Shown) => None + | Pristine + | Dirty(_, Hidden) => + switch (validator.strategy) { + | OnFirstChange + | OnFirstSuccess + | OnSubmit => Dirty(validator.validate(input), Hidden)->setStatus->Some + | OnFirstBlur + | OnFirstSuccessOrFirstBlur => + switch (validator.validate(input)) { + | Ok(x) => Validating(x)->setStatus->Some + | Error(_) as result => Dirty(result, Shown)->setStatus->Some + } + } + }; + }; + + let validateFieldOfOptionTypeOnBlur = + ( + ~input: 'input, + ~fieldStatus: fieldStatus('outputValue, 'message), + ~validator: singleValueValidator('input, 'outputValue, 'message), + ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, + ) + : option('statuses) => { + switch (fieldStatus) { + | Validating(_) + | Dirty(_, Shown) => None + | Pristine + | Dirty(_, Hidden) => + switch (validator.strategy) { + | OnFirstChange + | OnFirstSuccess + | OnSubmit => Dirty(validator.validate(input), Hidden)->setStatus->Some + | OnFirstBlur + | OnFirstSuccessOrFirstBlur => + switch (validator.validate(input)) { + | Ok(Some(_) as x) => Validating(x)->setStatus->Some + | Ok(None) as result + | Error(_) as result => Dirty(result, Shown)->setStatus->Some + } + } + }; + }; + + let validateFieldOfStringTypeOnBlur = + ( + ~input: 'input, + ~fieldStatus: fieldStatus(string, 'message), + ~validator: singleValueValidator('input, string, 'message), + ~setStatus: fieldStatus(string, 'message) => 'statuses, + ) + : option('statuses) => { + switch (fieldStatus) { + | Validating(_) + | Dirty(_, Shown) => None + | Pristine + | Dirty(_, Hidden) => + switch (validator.strategy) { + | OnFirstChange + | OnFirstSuccess + | OnSubmit => Dirty(validator.validate(input), Hidden)->setStatus->Some + | OnFirstBlur + | OnFirstSuccessOrFirstBlur => + switch (validator.validate(input)) { + | Ok("") as result + | Error(_) as result => Dirty(result, Shown)->setStatus->Some + | Ok(x) => Validating(x)->setStatus->Some + } + } + }; + }; + + let validateFieldOfOptionStringTypeOnBlur = + ( + ~input: 'input, + ~fieldStatus: fieldStatus(option(string), 'message), + ~validator: singleValueValidator('input, option(string), 'message), + ~setStatus: fieldStatus(option(string), 'message) => 'statuses, + ) + : option('statuses) => { + switch (fieldStatus) { + | Validating(_) + | Dirty(_, Shown) => None + | Pristine + | Dirty(_, Hidden) => + switch (validator.strategy) { + | OnFirstChange + | OnFirstSuccess + | OnSubmit => Dirty(validator.validate(input), Hidden)->setStatus->Some + | OnFirstBlur + | OnFirstSuccessOrFirstBlur => + switch (validator.validate(input)) { + | Ok(Some("")) as result + | Ok(None) as result + | Error(_) as result => Dirty(result, Shown)->setStatus->Some + | Ok(Some(_) as x) => Validating(x)->setStatus->Some + } + } + }; + }; +}; diff --git a/lib/src/FormalityCompat__FormAsyncOnBlurWithId.re b/lib/src/FormalityCompat__FormAsyncOnBlurWithId.re index 51032dbf..60de4602 100644 --- a/lib/src/FormalityCompat__FormAsyncOnBlurWithId.re +++ b/lib/src/FormalityCompat__FormAsyncOnBlurWithId.re @@ -236,7 +236,6 @@ module Make = (Form: Form) => { }) | OnFirstBlur | OnFirstSuccessOrFirstBlur => - let result = state.input->(validator.validate); switch (result, validator.validateAsync) { | (_, None) => Update({ @@ -269,7 +268,7 @@ module Make = (Form: Form) => { ...state, fields: state.fields->Map.set(field, Dirty(result, Shown)), }) - }; + } }; };