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..ca4afbf0 100644 --- a/examples/src/SignupForm.re +++ b/examples/src/SignupForm.re @@ -1,21 +1,11 @@ module SignupForm = [%form type input = { - email: string, + email: [@field.async] string, password: [@field.deps passwordConfirmation] string, passwordConfirmation: string, }; - type output = input -]; - -let initialInput: SignupForm.input = { - email: "", - password: "", - passwordConfirmation: "", -}; - -let validators: SignupForm.validators = { - email: - Some({ + let validators = { + email: { strategy: OnFirstSuccessOrFirstBlur, validate: ({email}) => { let emailRegex = [%bs.re {|/.*@.*\..+/|}]; @@ -26,9 +16,20 @@ let validators: SignupForm.validators = { | _ => Ok(email) }; }, - }), - password: - Some({ + validateAsync: email => + Js.Promise.( + email + ->Api.validateEmail + ->then_( + valid => + valid + ? Ok(email)->resolve + : Error("Email is already taken")->resolve, + _, + ) + ), + }, + password: { strategy: OnFirstSuccessOrFirstBlur, validate: ({password}) => { let minLength = 4; @@ -39,9 +40,8 @@ let validators: SignupForm.validators = { | _ => Ok(password) }; }, - }), - passwordConfirmation: - Some({ + }, + passwordConfirmation: { strategy: OnFirstSuccessOrFirstBlur, validate: ({password, passwordConfirmation}) => switch (passwordConfirmation) { @@ -50,7 +50,14 @@ let validators: SignupForm.validators = { Error("Password doesn't match") | _ => Ok(passwordConfirmation) }, - }), + }, + } +]; + +let initialInput: SignupForm.input = { + email: "", + password: "", + passwordConfirmation: "", }; [@react.component] @@ -58,7 +65,6 @@ let make = () => { let form = SignupForm.useForm( ~initialInput, - ~validators, ~onSubmit=(output, form) => { Js.log2("Submitted with:", output); Js.Global.setTimeout( @@ -94,11 +100,13 @@ let make = () => { } /> {switch (form.emailResult()) { - | Some(Error(message)) => + | Some(Validating(_)) => +
"Checking..."->React.string
+ | Some(Result(Error(message))) =>
message->React.string
- | Some(Ok(_)) => + | Some(Result(Ok(_))) =>
{j|✓|j}->React.string
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..6ac81313 100644 --- a/lib/ppx/Form.re +++ b/lib/ppx/Form.re @@ -5,1031 +5,161 @@ 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 ext = + Extension.declare( + "form", + Extension.Context.module_expr, + Ast_pattern.__, + (~loc, ~path as _, expr) => { + switch (expr) { + | PStr(structure) => + switch (structure |> Metadata.make) { + | Ok({ + scheme, + async, + output_type, + message_type, + submission_error_type, + validators_record, + debounce_interval, + }) => + // Once we gathered all required metadata and ensured that requirements are met + // We need to iterate over user provided config and do the following: + // 1. Open Formality module at the top of the generated module + // 2. Inject types and values that either + // optional and weren't provided or just generated by ppx + // 3. Update validators record (see Form_ValidatorsRecord for details) + // 4. Append neccessary functions including useForm hook + // + // The strategy would be to find structure_item which contains + // validators record and prepend types and values right before it. + // Then prepend `open Formality` at the top & append functions + // to the result list so those are at the bottom of the module. + let opens = [Form_OpenFormality.ast(~loc)]; - 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; + let types = { + let types = + ref([ + Form_FieldsStatusesType.ast(~loc, scheme), + Form_StateType.ast(~loc), + Form_ActionType.ast(~loc, scheme), + Form_ValidatorsType.ast(~loc, scheme), + Form_InterfaceType.ast(~loc, ~async, scheme), + ]); + switch (submission_error_type) { + | None => types := [SubmissionErrorType.default(~loc), ...types^] + | Some () => () + }; + switch (message_type) { + | None => types := [MessageType.default(~loc), ...types^] + | Some () => () + }; + switch (output_type) { + | NotProvided => types := [OutputType.default(~loc), ...types^] + | AliasOfInput + | Record(_) => () + }; + types^; + }; - %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, - ); - }; + let values = { + let values = ref([]); + switch (debounce_interval) { + | None when async => + values := [DebounceInterval.default(~loc), ...values^] + | None + | Some () => () + }; + values^; + }; - 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 funcs = [ + 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), + ]; - 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, - }), + let structure: structure = + List.fold_right( + (structure_item: structure_item, acc) => + switch (structure_item) { + | {pstr_desc: Pstr_value(rec_flag, value_bindings), pstr_loc} => + let (value_bindings, search_result) = + List.fold_right( + (value, (acc, res: [ | `Found | `NotFound])) => + switch (value) { + | { + pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}, + } as value => ( + [ + value + |> Form_ValidatorsRecord.ast( + scheme, + validators_record, + ), + ...acc, + ], + `Found, + ) + | _ as value => ([value, ...acc], res) + }, + value_bindings, + ([], `NotFound), + ); + let structure_item = { + pstr_desc: Pstr_value(rec_flag, value_bindings), + pstr_loc, + }; + switch (search_result) { + | `NotFound => [structure_item, ...acc] + | `Found => + List.append( + List.append(types, values), + [structure_item, ...acc], ) - | 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}) + }; + | _ => [structure_item, ...acc] }, - ), - 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), + structure, + funcs, ); - } - }); - - // 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), - ); - }; - } -]; + Mod.mk(Pmod_structure(List.append(opens, structure))); -let ext = - Extension.declare( - "form", - Extension.Context.module_expr, - Ast_pattern.__, - (~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), - ]), - ) | 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,11 +167,9 @@ 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)) => - Location.raise_errorf(~loc, "`output` type not found") | Error(OutputTypeParseError(NotRecord(loc))) => Location.raise_errorf( ~loc, @@ -1052,6 +180,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 +233,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 +250,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_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_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_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_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..80aa09de --- /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}) => { + let validator = [%e field |> E.field(~of_="validators", ~loc)]; + validator.validateAsync((value, dispatch)); + }, + ) + | 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..b51239c4 --- /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}) => { + let validator = [%e field |> E.field(~of_="validators", ~loc)]; + validator.validateAsync((value, dispatch)); + }, + ) + | 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..4f9eecf5 --- /dev/null +++ b/lib/ppx/Form_ValidatorsRecord.re @@ -0,0 +1,162 @@ +open Meta; +open Ast; +open AstHelpers; + +open Ppxlib; +open Ast_helper; + +// What we need to do here: +// 1. Update values of optional validators: set them to () instead of None +// 2. Wrap async validators so each dispatches appropriate action +// 3. Debounce async validators that run on change +// 4. Don't touch unknown, let compiler do its job +let ast = + ( + scheme: Scheme.t, + validators_record: ValidatorsRecord.t, + value_binding: value_binding, + ) => { + let fields = + validators_record.fields + |> List.map(((flid, expr)) => + switch (flid) { + | {txt: Lident(field)} => + let entry = + scheme + |> List.find_opt( + fun + | Scheme.Field({name}) => name == field, + ); + switch (entry) { + | Some(Field({name, validator, output_type})) => + switch (validator) { + | SyncValidator(Ok(Required)) => (flid, expr) + | SyncValidator(Ok(Optional(Some ()))) => (flid, expr) + | SyncValidator(Ok(Optional(None))) => + let loc = expr.pexp_loc; + (flid, [%expr ()]); + | SyncValidator(Error ()) => (flid, expr) + | AsyncValidator({mode: async_mode}) => ( + flid, + switch (expr) { + | { + pexp_desc: Pexp_record(fields, None), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + } => + let fields_with_eq = + if (fields + |> List.exists((({txt: lid}, _)) => + switch (lid) { + | Lident("eq") => true + | _ => false + } + )) { + fields; + } else { + let loc = pexp_loc; + [ + (Lident("eq") |> lid(~loc), [%expr (==)]), + ...fields, + ]; + }; + let fields_with_eq_and_wrapped_async_validator = + fields_with_eq + |> List.map(((vlid, {pexp_loc: loc} as expr)) => + switch (vlid) { + | {txt: Lident("validateAsync")} => + let fn = [%expr + ( + ((value, dispatch)) => { + Js.log2( + "Executed async validator with value:", + value, + ); + let validate: + Async.validateAsyncFn( + [%t output_type |> FieldType.unpack], + message, + ) = [%e + expr + ]; + Async.validateAsync( + ~value, ~validate, ~andThen=res => { + dispatch( + [%e + Exp.construct( + Lident( + Field.Field(name) + |> Field.apply_async_result_action, + ) + |> lid(~loc), + Some( + Exp.tuple([ + Exp.ident( + Lident("value") |> lid(~loc), + ), + Exp.ident( + Lident("res") |> lid(~loc), + ), + ]), + ), + ) + ], + ) + }); + } + ) + ]; + ( + vlid, + switch (async_mode) { + | OnBlur => fn + | OnChange => + %expr + Debouncer.make( + ~wait=debounceInterval, + [%e fn], + ) + }, + ); + | _ => (vlid, expr) + } + ); + { + pexp_desc: + Pexp_record( + fields_with_eq_and_wrapped_async_validator, + None, + ), + pexp_loc, + pexp_loc_stack, + pexp_attributes, + }; + | _ => expr + }, + ) + } + | None => (flid, expr) + }; + | _ => (flid, expr) + } + ); + { + ...value_binding, + pvb_expr: { + pexp_desc: + Pexp_constraint( + { + pexp_desc: Pexp_record(fields, None), + pexp_loc: validators_record.record_metadata.pexp_loc, + pexp_loc_stack: validators_record.record_metadata.pexp_loc_stack, + pexp_attributes: validators_record.record_metadata.pexp_attributes, + }, + validators_record.annotation, + ), + pexp_loc: validators_record.constraint_metadata.pexp_loc, + pexp_loc_stack: validators_record.constraint_metadata.pexp_loc_stack, + pexp_attributes: validators_record.constraint_metadata.pexp_attributes, + }, + }; +}; diff --git a/lib/ppx/Form_ValidatorsType.re b/lib/ppx/Form_ValidatorsType.re new file mode 100644 index 00000000..f5c5764b --- /dev/null +++ b/lib/ppx/Form_ValidatorsType.re @@ -0,0 +1,33 @@ +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, + action, + ) + ] + } + ); +}; diff --git a/lib/ppx/Meta.re b/lib/ppx/Meta.re index 5fdd028f..5f8eff69 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,7 +73,175 @@ module FieldType = { let eq = (x1: t, x2: t) => eq(x1 |> unpack, x2 |> unpack); }; -module FieldDeps = { +module FieldOptionality = { + type t = + | OptionType + | StringType + | OptionStringType; +}; + +module AsyncMode = { + type t = + | OnChange + | OnBlur; + + let default = OnChange; +}; + +module ValidatorsRecord = { + type t = { + fields, + rec_flag, + constraint_metadata: metadata, + record_metadata: metadata, + annotation: core_type, + } + and fields = list((loc(Longident.t), expression)) + and metadata = { + pexp_loc: Location.t, + pexp_loc_stack: list(Location.t), + pexp_attributes: list(attribute), + }; +}; + +module FieldValidator = { + type t = + | SyncValidator(result(sync, unit)) + | AsyncValidator({ + mode: AsyncMode.t, + optionality: option(FieldOptionality.t), + }) + and sync = + | Required + | Optional(option(unit)); +}; + +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 = { + module T: {type t;} = { + type t = type_declaration; + }; + + type t = T.t; + external make: type_declaration => t = "%identity"; + external type_declaration: t => type_declaration = "%identity"; +}; + +module OutputType = { + module T: {type t;} = { + type t = type_declaration; + }; + + type t = T.t; + external make: type_declaration => t = "%identity"; + external type_declaration: t => type_declaration = "%identity"; + + let default = (~loc) => [%stri type output = input]; +}; + +module MessageType = { + let default = (~loc) => [%stri type message = string]; +}; + +module DebounceInterval = { + let default = (~loc) => [%stri let debounceInterval = 700]; +}; + +module SubmissionErrorType = { + let default = (~loc) => [%stri type submissionError = unit]; +}; + +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 = @@ -73,7 +250,7 @@ module FieldDeps = { | DepOfItself(unvalidated_dep) | DepDuplicate(unvalidated_dep); - let from_attributes = (attributes: list(attribute)) => { + let parse = (attributes: list(attribute)) => { let deps_attr = attributes |> List.find_opt(attr => @@ -111,116 +288,381 @@ module FieldDeps = { | Some({attr_loc}) => Error(DepsParseError(attr_loc)) }; }; -}; - -module FieldSpec = { - type t = { - id: Field.t, - input_type: FieldType.t, - output_type: FieldType.t, - validator: [ | `Required | `Optional], - deps: list(Field.t), - }; -}; -module InputType = { - module T: {type t;} = { - type t = structure_item; - }; - - type t = T.t; - external pack: structure_item => t = "%identity"; - external structure_item: t => structure_item = "%identity"; - - let make = (~loc: Location.t, ~rec_flag: rec_flag, decl: type_declaration) => - decl |> StructureItem.from_type_declaration(~loc, ~rec_flag) |> pack; -}; - -module OutputType = { - module T: {type t;} = { - type t = structure_item; - }; - - type t = T.t; - external pack: structure_item => t = "%identity"; - external structure_item: t => structure_item = "%identity"; - - let make = (~loc: Location.t, ~rec_flag: rec_flag, decl: type_declaration) => - decl |> StructureItem.from_type_declaration(~loc, ~rec_flag) |> pack; -}; - -module MessageType = { - module T: {type t;} = { - type t = structure_item; - }; - - type t = T.t; - external pack: structure_item => t = "%identity"; - external structure_item: t => structure_item = "%identity"; - - let make = (~loc: Location.t, ~rec_flag: rec_flag, decl: type_declaration) => - decl |> StructureItem.from_type_declaration(~loc, ~rec_flag) |> pack; - - let default = (~loc) => [%stri type message = string] |> pack; -}; - -module SubmissionErrorType = { - module T: {type t;} = { - type t = structure_item; - }; - - type t = T.t; - external pack: structure_item => t = "%identity"; - external structure_item: t => structure_item = "%identity"; - - let make = (~loc: Location.t, ~rec_flag: rec_flag, decl: type_declaration) => - decl |> StructureItem.from_type_declaration(~loc, ~rec_flag) |> pack; - - let default = (~loc) => [%stri type submissionError = unit] |> pack; + 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))), - structure_item: InputType.t, + fields, + type_declaration: 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, type_declaration: decl |> InputType.make}) + }; + }; + + 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 = { type result = Pervasives.result(ok, error) and ok = - | AliasOfInput(OutputType.t) + | NotProvided + | AliasOfInput | Record({ fields: list((Field.t, FieldType.t, Location.t)), - structure_item: OutputType.t, loc: Location.t, }) and error = - | NotFound | NotRecord(Location.t) | BadTypeAlias({ alias: string, loc: Location.t, }); + + let parse_as_record = (~decl, ~loc, fields) => + Record({ + loc, + fields: + List.fold_right( + (field, acc) => + [ + ( + field |> Field.make, + field.pld_type |> FieldType.make, + field.pld_loc, + ), + ...acc, + ], + fields, + [], + ), + }); }; -module Data = { +module DebounceIntervalParser = { + let exists = (values: list(value_binding)) => + values + |> List.exists( + fun + | {pvb_pat: {ppat_desc: Ppat_var({txt: "debounceInterval"})}} => + true + | _ => false, + ); +}; + +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 exists = (values: list(value_binding)) => + values + |> List.exists( + fun + | {pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}} => true + | _ => false, + ); + + let parse = (~rec_flag, values: list(value_binding)): option(result) => { + values + |> List.fold_left( + (res, value) => + switch (res) { + | Some(_) => res + | None => + switch (value) { + | { + pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}, + pvb_expr: { + pexp_desc: + Pexp_constraint( + expr, + {ptyp_desc: Ptyp_constr(typ, args), ptyp_loc} as annotation, + ), + pexp_loc: constraint_pexp_loc, + pexp_loc_stack: constraint_pexp_loc_stack, + pexp_attributes: constraint_pexp_attributes, + }, + } => + switch (typ, args) { + | ({txt: Lident("validators")}, []) => + switch (expr) { + | { + pexp_desc: Pexp_record(fields, None), + pexp_loc: record_pexp_loc, + pexp_loc_stack: record_pexp_loc_stack, + pexp_attributes: record_pexp_attributes, + } => + Some( + Ok( + ValidatorsRecord.{ + fields, + rec_flag, + annotation, + constraint_metadata: { + pexp_loc: constraint_pexp_loc, + pexp_loc_stack: constraint_pexp_loc_stack, + pexp_attributes: constraint_pexp_attributes, + }, + record_metadata: { + pexp_loc: record_pexp_loc, + pexp_loc_stack: record_pexp_loc_stack, + pexp_attributes: record_pexp_attributes, + }, + }, + ), + ) + | {pexp_loc} => Some(Error(NotRecord(pexp_loc))) + } + | ({txt: _}, _) => Some(Error(BadTypeAnnotation(ptyp_loc))) + } + | { + pvb_pat: {ppat_desc: Ppat_var({txt: "validators"})}, + pvb_expr: {pexp_loc} as expr, + } => + switch (expr) { + | { + pexp_desc: Pexp_record(fields, None), + pexp_loc: loc, + pexp_loc_stack, + pexp_attributes, + } => + Some( + Ok({ + fields, + rec_flag, + annotation: [%type: validators], + constraint_metadata: { + pexp_loc, + pexp_loc_stack, + pexp_attributes, + }, + record_metadata: { + pexp_loc, + pexp_loc_stack, + pexp_attributes, + }, + }), + ) + | {pexp_loc} => Some(Error(NotRecord(pexp_loc))) + } + | _ => None + } + }, + None, + ); + }; + + let find = (field: Field.t, validators: ValidatorsRecord.fields) => + 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.fields) => { + 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.fields) => { + switch (field, validators |> find(field)) { + | (Field(field), Some((_, {pexp_desc: Pexp_record(_)}))) => Ok(Some()) + | ( + Field(field), + Some(( + _, + {pexp_desc: Pexp_construct({txt: Lident("None")}, None)}, + )), + ) => + Ok(None) + | (Field(field), Some(_)) => Error(`BadValue) + | (Field(field), None) => Error(`NotFound) + }; + }; +}; + +module Metadata = { type t = { - fields: list(FieldSpec.t), - input_type: InputType.t, - output_type: OutputType.t, - message_type: MessageType.t, - submission_error_type: SubmissionErrorType.t, + scheme: Scheme.t, + async: bool, // meh, it should be variant: Sync(_) | Async(_) + output_type: OutputTypeParser.ok, + validators_record: ValidatorsRecord.t, + message_type: option(unit), + submission_error_type: option(unit), + debounce_interval: option(unit), }; type error = | InputTypeParseError(InputTypeParser.error) | OutputTypeParseError(OutputTypeParser.error) + | ValidatorsRecordParseError(ValidatorsRecordParser.error) | IOMismatch(io_mismatch) and io_mismatch = | InputFieldsNotInOutput({ @@ -237,11 +679,14 @@ module Data = { let make = (structure: structure) => { let input_parsing_result: ref(option(InputTypeParser.result)) = ref(None); - let output_parsing_result: ref(option(OutputTypeParser.result)) = - ref(None); - let message_type: ref(option(MessageType.t)) = ref(None); - let submission_error_type: ref(option(SubmissionErrorType.t)) = + let output_parsing_result: ref(OutputTypeParser.result) = + ref(Ok(OutputTypeParser.NotProvided)); + let validators_record_parsing_result: + ref(option(ValidatorsRecordParser.result)) = ref(None); + let message_type: ref(option(unit)) = ref(None); + let submission_error_type: ref(option(unit)) = ref(None); + let debounce_interval_value: ref(option(unit)) = ref(None); structure |> List.iter( @@ -258,41 +703,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 := @@ -305,29 +721,12 @@ module Data = { ptype_loc, } as decl => 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), - }), - ), + Ok( + fields + |> OutputTypeParser.parse_as_record( + ~decl, + ~loc=ptype_loc, + ), ) | { ptype_name: {txt: "output"}, @@ -338,15 +737,8 @@ module Data = { ptyp_desc: Ptyp_constr({txt: Lident("input")}, []), }), - } as decl => - output_parsing_result := - Some( - Ok( - AliasOfInput( - decl |> OutputType.make(~loc=ptype_loc, ~rec_flag), - ), - ), - ) + } => + output_parsing_result := Ok(AliasOfInput) | { ptype_name: {txt: "output"}, ptype_kind: Ptype_abstract, @@ -357,116 +749,149 @@ module Data = { }), } => output_parsing_result := - Some( - Error(OutputTypeParser.BadTypeAlias({alias, loc})), - ) + Error(OutputTypeParser.BadTypeAlias({alias, loc})) | {ptype_name: {txt: "output"}, ptype_loc} => output_parsing_result := - Some(Error(OutputTypeParser.NotRecord(ptype_loc))) + Error(OutputTypeParser.NotRecord(ptype_loc)) // Message type | { ptype_name: {txt: "message"}, ptype_loc, ptype_manifest: Some(_), - } as decl => - message_type := - Some( - decl |> MessageType.make(~rec_flag, ~loc=ptype_loc), - ) + } => + message_type := Some() // Submission error type | { ptype_name: {txt: "submissionError"}, ptype_loc, ptype_manifest: Some(_), - } as decl => - submission_error_type := - Some( - decl - |> SubmissionErrorType.make(~rec_flag, ~loc=ptype_loc), - ) + } => + submission_error_type := Some() // Rest | _ => (), ); } + | {pstr_desc: Pstr_value(rec_flag, values)} => { + if (values |> DebounceIntervalParser.exists) { + debounce_interval_value := Some(); + }; + switch (values |> ValidatorsRecordParser.parse(~rec_flag)) { + | Some(x) => validators_record_parsing_result := Some(x) + | None => () + }; + } | _ => (), ); - 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_parsing_result^, + ) { + | (Some(Error(error)), _, _) => Error(InputTypeParseError(error)) + | (None, _, _) => Error(InputTypeParseError(NotFound)) + | (_, Error(error), _) => Error(OutputTypeParseError(error)) + | (_, _, None) => Error(ValidatorsRecordParseError(NotFound)) + | (_, _, Some(Error(error))) => + Error(ValidatorsRecordParseError(error)) + | ( + Some(Ok(input_data)), + Ok(output_result), + Some(Ok(validators_record)), + ) => + switch (input_data.fields |> FieldDepsParser.validate) { | Error(error) => Error(InputTypeParseError(InvalidFieldDeps(error))) | Ok () => - let fields = + let scheme: result(Scheme.t, error) = switch (output_result) { - | AliasOfInput(_) => - Ok( - 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, - ), + | NotProvided + | AliasOfInput => + input_data.fields + |> 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_record.fields + |> 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_record.fields + |> 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, @@ -475,7 +900,12 @@ module Data = { ) = List.fold_right( ( - (input_field, input_field_type, input_field_deps), + ( + input_field, + input_field_type, + input_field_async_mode, + input_field_deps, + ), ( matched_fields, input_fields_not_in_output, @@ -487,49 +917,146 @@ module Data = { |> List.find_opt(((output_field, _, _)) => input_field |> Field.eq(output_field) ); - switch (output_field) { - | None => ( + switch (matched_fields, output_field) { + | (_, None) => ( matched_fields, [input_field, ...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: - if (FieldType.eq( - input_field_type, - output_field_type, - )) { - `Optional; - } else { - `Required; - }, - deps: - input_field_deps - |> List.map( - fun - | `Field(dep, _) => dep |> Field.from_string, - ), - }, - ...matched_fields, - ], + | ( + 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_record.fields + |> 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, + )) { + switch ( + validators_record.fields + |> 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 { + switch ( + validators_record.fields + |> 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, + ]) + }, + 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), + (Ok([]), [], output_fields), ); switch (input_fields_not_in_output, output_fields_not_in_input) { - | ([], []) => Ok(matched_fields) + | ([], []) => matched_fields | (input_fields_not_in_output, []) => Error( IOMismatch( @@ -564,30 +1091,31 @@ module Data = { }; }; - switch (fields) { - | Ok(fields) => + switch (scheme) { + | Ok(scheme) => 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) - }, + scheme, + async: + // TODO: Quick and dirty. + // Scheme.t should be wrapped in variant instead, probably. + // 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 + } + ), + output_type: output_result, + validators_record, + message_type: message_type^, + submission_error_type: submission_error_type^, + debounce_interval: debounce_interval_value^, }) | Error(error) => Error(error) }; - }; + } }; }; }; diff --git a/lib/ppx/Ppx.re b/lib/ppx/Ppx.re index 584039ac..4c7ddc58 100644 --- a/lib/ppx/Ppx.re +++ b/lib/ppx/Ppx.re @@ -1,9 +1,8 @@ -// 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: [Public Api] Change `updateField` siganture so it accepts `input => input` instead of `input` +// TODO: [Meta] In some cases (records?) order of items is reversed. +// 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..4de1544c 100644 --- a/lib/src/Formality.re +++ b/lib/src/Formality.re @@ -1,3 +1,4 @@ +module Debouncer = Formality__Debouncer; module ReactUpdate = Formality__ReactUpdate; type strategy = @@ -15,11 +16,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 +26,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 +42,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 +52,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 +66,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 +99,6 @@ let validateFieldOnChangeWithValidator = }; }; -let validateFieldOnChangeWithoutValidator = - ( - ~fieldInput: 'outputValue, - ~setStatus: fieldStatus('outputValue, 'message) => 'statuses, - ) - : 'statuses => { - Dirty(Ok(fieldInput), Hidden)->setStatus; -}; - let validateFieldDependencyOnChange = ( ~input: 'input, @@ -119,10 +111,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 +142,429 @@ 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, 'action) = { + strategy, + validate: 'input => result('outputValue, 'message), + validateAsync: (('outputValue, 'action => unit)) => unit, + 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, 'action) = { + strategy, + validate: ('input, ~at: index) => result('outputValue, 'message), + validateAsync: (~value: 'outputValue, ~dispatch: 'action => unit) => unit, + eq: ('outputValue, 'outputValue) => bool, + }; + + type validateAsyncFn('outputValue, 'message) = + 'outputValue => Js.Promise.t(result('outputValue, 'message)); + + let validateAsync = + ( + ~value: 'outputValue, + ~validate: validateAsyncFn('outputValue, 'message), + ~andThen: result('outputValue, 'message) => unit, + ) + : unit => + validate(value) + ->Js.Promise.(then_(res => res->andThen->resolve, _)) + ->ignore; + + 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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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, 'action), + ~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)), }) - }; + } }; }; diff --git a/lib/src/Formality__Debouncer.re b/lib/src/Formality__Debouncer.re new file mode 100644 index 00000000..ded23dcc --- /dev/null +++ b/lib/src/Formality__Debouncer.re @@ -0,0 +1 @@ +include Debouncer;