diff --git a/README.md b/README.md index fd87702..72950cf 100644 --- a/README.md +++ b/README.md @@ -29,3 +29,19 @@ Generate validating forms from JSON schemas. - Categorization Example - Implement prev/next buttons - Implement stepper variant + +# Changelog + +## 2.0.0 + +* Produce an intermediate representation instead of the HTML view. This allows much richer view customization. + * A default Tailwind view function is available. It can be used as a starting point for a custom view implementation. +* Display errors on fields only after they have been touched, or after a submit was triggered. +* Trim text fields + +## 1.0.0 + +- Can handle most of the UI Schema specification +- Can handle almost all JSON Schema features (draft-04 and draft-06). +- Generates all common types of input fields (`text`, `select`, etc.) with optional labels and descriptions. +- Comes with default Tailwind CSS theme in the `Theme` object that can be customised. \ No newline at end of file diff --git a/elm.json b/elm.json index 2458446..814d220 100644 --- a/elm.json +++ b/elm.json @@ -3,11 +3,11 @@ "name": "scrive/elm-json-forms", "summary": "JSON Forms Implementation in Elm.", "license": "MIT", - "version": "1.0.0", + "version": "2.0.0", "exposed-modules": [ "Form", + "Form.Widget", "Form.Error", - "Form.Theme", "Json.Pointer", "UiSchema" ], diff --git a/example/src/Main.elm b/example/src/Main.elm index a8b2602..d3a2565 100644 --- a/example/src/Main.elm +++ b/example/src/Main.elm @@ -2,6 +2,7 @@ module Main exposing (main) import Browser import Browser.Navigation as Nav +import Cmd.Extra as Cmd import Examples exposing (exampleForms) import Form exposing (Form) import Html exposing (..) @@ -15,7 +16,6 @@ import Json.Schema import List.Extra as List import Maybe.Extra as Maybe import Model exposing (..) -import Settings import UiSchema import Url import Url.Parser @@ -47,11 +47,16 @@ update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of ExampleMsg i m -> - ( { model - | forms = List.updateAt i (updateExample m) model.forms - } - , Cmd.none - ) + case List.getAt i model.forms |> Maybe.map (updateExample m) of + Nothing -> + ( model, Cmd.none ) + + Just ( st, cmd ) -> + ( { model + | forms = List.updateAt i (always st) model.forms + } + , Cmd.map (ExampleMsg i) cmd + ) UrlChanged url -> case parseUrl url of @@ -80,46 +85,55 @@ parseUrl url = Maybe.join <| Url.Parser.parse (Url.Parser.query <| Url.Parser.Query.int "example") { url | path = "" } -updateExample : ExampleMsg -> FormState -> FormState +updateExample : ExampleMsg -> FormState -> ( FormState, Cmd ExampleMsg ) updateExample msg fs = case msg of FormMsg formMsg -> - { fs | form = Maybe.map (Form.update formMsg) fs.form } + ( { fs | form = Maybe.map (Form.update formMsg) fs.form }, Cmd.none ) EditSchema s -> case Json.Schema.fromString s of Ok schema -> - { fs + ( { fs | stringSchema = s , form = Maybe.map (Form.setSchema schema) fs.form , schemaError = Nothing - } + } + , Cmd.none + ) Err e -> - { fs + ( { fs | stringSchema = s , schemaError = Just e - } + } + , Cmd.none + ) + + Submit -> + ( fs, Cmd.perform (FormMsg Form.validateAllFieldsMsg) ) EditUiSchema s -> case UiSchema.fromString s of Ok uiSchema -> - { fs + ( { fs | stringUiSchema = Just s , form = Maybe.map (Form.setUiSchema (Just uiSchema)) fs.form , uiSchemaError = Nothing - } + } + , Cmd.none + ) Err e -> - { fs + ( { fs | stringUiSchema = Just s , uiSchemaError = Just e - } + } + , Cmd.none + ) SwitchTab t -> - { fs - | tab = t - } + ( { fs | tab = t }, Cmd.none ) view : Model -> Browser.Document Msg @@ -179,12 +193,19 @@ viewExample fs = Just form -> div [ class "border shadow rounded p-3 bg-white" ] - [ Html.map FormMsg (Form.view form) ] + [ Html.map FormMsg (Form.viewWidget (Form.widget form)) + , button + [ Attrs.class "bg-blue-500 text-white p-2 rounded" + , Events.onClick Submit + ] + [ text "Validate" ] + ] ] ] , div [ class "w-full lg:w-1/2 px-2" ] [ div [ class "border-b mb-3" ] - [ viewTabHeader [] fs.tab DataTab + [ viewTabHeader [] fs.tab RawDataTab + , viewTabHeader [] fs.tab SubmitDataTab , viewTabHeader [ if fs.schemaError /= Nothing then class "line-through" @@ -205,8 +226,11 @@ viewExample fs = UiSchemaTab ] , div [] - [ div [ Attrs.hidden (fs.tab /= DataTab) ] - [ Html.viewMaybe viewData fs.form + [ div [ Attrs.hidden (fs.tab /= RawDataTab) ] + [ Html.viewMaybe viewRawData fs.form + ] + , div [ Attrs.hidden (fs.tab /= SubmitDataTab) ] + [ Html.viewMaybe viewSubmitData fs.form ] , div [ Attrs.hidden (fs.tab /= JsonSchemaTab) ] [ textarea [ Attrs.name "JsonSchema", Events.onInput EditSchema, Attrs.rows 30 ] fs.stringSchema @@ -245,8 +269,11 @@ viewTabHeader attrs activeTab tab = ) [ text <| case tab of - DataTab -> - "Data" + RawDataTab -> + "Raw Data" + + SubmitDataTab -> + "Submit Data" JsonSchemaTab -> "JSON Schema" @@ -269,14 +296,27 @@ viewError title err = ] -viewData : Form -> Html a -viewData form = - let - dataText = - Encode.encode 4 (Form.getValue form) +viewRawData : Form -> Html a +viewRawData form = + viewData form <| Encode.encode 4 <| Form.getRawValue form + + +viewSubmitData : Form -> Html a +viewSubmitData form = + viewData form <| + case Form.getSubmitValue form of + Nothing -> + "" + Just v -> + Encode.encode 4 v + + +viewData : Form -> String -> Html a +viewData form dataText = + let errorsText = - String.join "\n" (List.map (\( pointer, err ) -> Pointer.toString pointer ++ ": " ++ Settings.errorString err) <| Form.getErrors form) + String.join "\n" (List.map (\( pointer, err ) -> Pointer.toString pointer ++ ": " ++ Form.errorString err) <| Form.getErrors form) in div [] [ textarea [ Attrs.id "Data", Attrs.readonly True, Attrs.rows 15 ] dataText diff --git a/example/src/Model.elm b/example/src/Model.elm index ac55db6..a5f60d3 100644 --- a/example/src/Model.elm +++ b/example/src/Model.elm @@ -5,7 +5,6 @@ import Browser.Navigation as Nav import Form exposing (Form) import Json.Schema import Result.Extra as Result -import Settings import UiSchema import Url @@ -22,7 +21,8 @@ type alias FormState = type Tab - = DataTab + = RawDataTab + | SubmitDataTab | JsonSchemaTab | UiSchemaTab @@ -42,6 +42,7 @@ type Msg type ExampleMsg = FormMsg Form.Msg + | Submit | EditSchema String | EditUiSchema String | SwitchTab Tab @@ -55,12 +56,15 @@ makeForm title stringSchema stringUiSchema = uiSchema = Maybe.map UiSchema.fromString stringUiSchema + + options = + Form.defaultOptions in case ( schema, uiSchema ) of ( Ok s, Nothing ) -> { title = title - , form = Just <| Settings.initForm title s Nothing - , tab = DataTab + , form = Just <| Form.init options title s Nothing + , tab = RawDataTab , stringSchema = stringSchema , stringUiSchema = Nothing , schemaError = Nothing @@ -69,8 +73,8 @@ makeForm title stringSchema stringUiSchema = ( Ok s, Just (Ok us) ) -> { title = title - , form = Just <| Settings.initForm title s (Just us) - , tab = DataTab + , form = Just <| Form.init options title s (Just us) + , tab = RawDataTab , stringSchema = stringSchema , stringUiSchema = stringUiSchema , schemaError = Nothing @@ -80,7 +84,7 @@ makeForm title stringSchema stringUiSchema = ( s, us ) -> { title = title , form = Nothing - , tab = DataTab + , tab = RawDataTab , stringSchema = stringSchema , stringUiSchema = stringUiSchema , schemaError = Result.error s diff --git a/example/src/Settings.elm b/example/src/Settings.elm deleted file mode 100644 index 81c7adf..0000000 --- a/example/src/Settings.elm +++ /dev/null @@ -1,94 +0,0 @@ -module Settings exposing (errorString, initForm) - -import Form exposing (Form) -import Form.Error exposing (ErrorValue(..)) -import Form.Theme as Theme -import Json.Encode as Encode -import Json.Schema.Definitions exposing (Schema) -import UiSchema exposing (UiSchema) - - -initForm : String -> Schema -> Maybe UiSchema -> Form -initForm = - Form.init - { errors = always errorString - , theme = Theme.scrive - } - - -errorString : ErrorValue -> String -errorString error = - case error of - Empty -> - "is a required property" - - NotConst v -> - case Encode.encode 0 v of - "true" -> - "must be checked" - - "false" -> - "must be unchecked" - - s -> - "must be equal to " ++ s - - InvalidString -> - "not a valid string" - - InvalidFormat _ -> - "not the correct format" - - InvalidInt -> - "not a valid integer" - - InvalidFloat -> - "not a valid number" - - InvalidBool -> - "not a valid option" - - InvalidNull -> - "not a null" - - LessIntThan n -> - "can not be smaller than " ++ String.fromInt n - - LessEqualIntThan n -> - "can not be smaller or equal than " ++ String.fromInt n - - GreaterIntThan n -> - "can not be greater than " ++ String.fromInt n - - GreaterEqualIntThan n -> - "can not be greater or equal than " ++ String.fromInt n - - LessFloatThan n -> - "can not be smaller than " ++ String.fromFloat n - - LessEqualFloatThan n -> - "can not be smaller or equal than " ++ String.fromFloat n - - GreaterFloatThan n -> - "can not be greater than " ++ String.fromFloat n - - GreaterEqualFloatThan n -> - "can not be greater or equal than " ++ String.fromFloat n - - ShorterStringThan n -> - "must NOT have fewer than " ++ String.fromInt n ++ " characters" - - LongerStringThan n -> - "must NOT have more than " ++ String.fromInt n ++ " characters" - - NotMultipleOfInt n -> - "must be a multiple of " ++ String.fromInt n ++ "." - - NotMultipleOfFloat n -> - "must be a multiple of " ++ String.fromFloat n ++ "." - - NotIncludedIn _ -> - "is not a valid selection from the list." - - Unimplemented s -> - "unimplemented: " ++ s diff --git a/review/elm.json b/review/elm.json index 28236fd..39eac39 100644 --- a/review/elm.json +++ b/review/elm.json @@ -9,7 +9,7 @@ "elm/core": "1.0.5", "elm/json": "1.1.3", "elm/project-metadata-utils": "1.0.2", - "jfmengels/elm-review": "2.13.1", + "jfmengels/elm-review": "2.15.1", "jfmengels/elm-review-code-style": "1.1.4", "jfmengels/elm-review-common": "1.3.3", "jfmengels/elm-review-debug": "1.0.8", @@ -19,7 +19,7 @@ "jfmengels/elm-review-unused": "1.2.0", "leojpod/review-no-empty-html-text": "1.0.2", "sparksp/elm-review-imports": "1.0.2", - "stil4m/elm-syntax": "7.3.2", + "stil4m/elm-syntax": "7.3.8", "truqu/elm-review-nobooleancase": "1.0.1", "truqu/elm-review-noleftpizza": "2.0.1", "truqu/elm-review-noredundantcons": "1.0.1" @@ -33,7 +33,6 @@ "elm/time": "1.0.0", "elm/virtual-dom": "1.0.3", "elm-explorations/test": "2.2.0", - "miniBill/elm-unicode": "1.1.1", "pzp1997/assoc-list": "1.0.0", "rtfeldman/elm-hex": "1.0.0", "stil4m/structured-writer": "1.0.3" diff --git a/src/Form.elm b/src/Form.elm index 96935c3..b407852 100644 --- a/src/Form.elm +++ b/src/Form.elm @@ -1,23 +1,25 @@ -module Form exposing (Form, Msg, init, update, view, getValue, getSchema, getUiSchema, getErrors, setSettings, setSchema, setUiSchema) +module Form exposing (Form, Msg, init, defaultOptions, update, widget, viewWidget, errorString, getRawValue, getSubmitValue, getSchema, getUiSchema, getErrors, setSchema, setUiSchema, validateAllFieldsMsg) {-| JSON Forms implementation with validations. Documentation for the original TypeScript library can be found here: -@docs Form, Msg, init, update, view, getValue, getSchema, getUiSchema, getErrors, setSettings, setSchema, setUiSchema +@docs Form, Msg, init, defaultOptions, update, widget, viewWidget, errorString, getRawValue, getSubmitValue, getSchema, getUiSchema, getErrors, setSchema, setUiSchema, validateAllFieldsMsg -} import Form.Error as Error -import Form.Settings exposing (Settings) import Form.State -import Form.Validation exposing (validation) -import Form.View -import Html exposing (Html, div) +import Form.Validation exposing (validate) +import Form.Widget +import Form.Widget.Generate +import Form.Widget.View +import Html exposing (Html) import Json.Decode exposing (Value) import Json.Pointer exposing (Pointer) import Json.Schema.Definitions exposing (Schema) import Maybe.Extra as Maybe +import UiSchema as UI import UiSchema.Internal exposing (UiSchema, defaultValue, generateUiSchema) @@ -33,31 +35,78 @@ type alias Msg = Form.State.Msg -{-| Initialize form state +{-| Enable form validations for all fields. + +Until this message is triggered, fields are validated only after input. + -} -init : Settings -> String -> Schema -> Maybe UiSchema -> Form -init settings id schema uiSchema = - { settings = settings - , schema = schema +validateAllFieldsMsg : Msg +validateAllFieldsMsg = + Form.State.ValidateAll + + +{-| Initialize form state. + +Supplying anything other than [`defaultOptions`](#defaultOptions) into the `init` function +causes the resulting form to differ from json-forms.io specification. These differences +should be documented. + +-} +init : UI.DefOptions -> String -> Schema -> Maybe UiSchema -> Form +init options id schema uiSchema = + { schema = schema , uiSchema = Maybe.withDefaultLazy (always <| generateUiSchema schema) uiSchema , uiSchemaIsGenerated = uiSchema == Nothing - , state = Form.State.initState id (defaultValue schema) (validation schema) + , state = Form.State.initState id (defaultValue schema) (validate schema) + , defaultOptions = options } -{-| Swap the Settings of an existing form +{-| Default element options. +-} +defaultOptions : UI.DefOptions +defaultOptions = + UI.defaultOptions + -Form data is not affected, only the view may change. +{-| Render the form into an abstract view representation. + +This representation can in turn be rendered into HTML by [`viewWidget`](#viewWidget), +or by a custom function. + +Widget type is documented in the [`Form.Widget`](Form-Widget) module. -} -setSettings : Settings -> Form -> Form -setSettings settings form = - { form - | settings = settings - } +widget : Form -> Form.Widget.Widget +widget = + Form.Widget.Generate.widget + + +{-| View a widget. + +This function can be used as a template for your own view function. + +Widget type is documented in the [`Form.Widget`](Form-Widget) module. +-} +viewWidget : Form.Widget.Widget -> Html Msg +viewWidget = + Form.Widget.View.viewWidget + + +{-| Convert an error value to a string. -{-| Swap the Schema of an existing form +This function can be used as a template for your own error messages. + +Error value is documented in the [`Form.Error`](Form-Error) module. + +-} +errorString : Error.ErrorValue -> String +errorString = + Form.Widget.View.errorString + + +{-| Swap the Schema of an existing form. Form data is reset. UI Schema is re-generated if it was auto-generated in the first place. @@ -72,11 +121,11 @@ setSchema schema form = else form.uiSchema - , state = Form.State.initState form.state.formId (defaultValue schema) (validation schema) + , state = Form.State.initState form.state.formId (defaultValue schema) (validate schema) } -{-| Swap the UI Schema of an existing form +{-| Swap the UI Schema of an existing form. Form data is preserved. @@ -89,13 +138,6 @@ setUiSchema uiSchema form = } -{-| View the form --} -view : Form -> Html Msg -view form = - div [] <| Form.View.view form { uiPath = [], disabled = False, uiSchema = form.uiSchema } - - {-| Update the form -} update : Msg -> Form -> Form @@ -103,7 +145,7 @@ update msg form = { form | state = Form.State.updateState - (validation form.schema) + (validate form.schema) msg form.state } @@ -111,15 +153,27 @@ update msg form = {-| Get the current form value. -The returned value may not be conforming to the JSON Schema if the -list of validation errors returned by `getErrors` is non-empty. +The returned value reflects the current form contents. +It is not normalized, and may not be conforming to the JSON Schema. +To get a normalized value conforming to the JSON Schema, use [`getSubmitValue`](#getSubmitValue). -} -getValue : Form -> Value -getValue form = +getRawValue : Form -> Value +getRawValue form = form.state.value +{-| Get the current form value. + +The value is present only if form validation passes with no errors. + +-} +getSubmitValue : Form -> Maybe Value +getSubmitValue form = + validate form.schema form.state.value + |> Result.toMaybe + + {-| Get the current Schema -} getSchema : Form -> Schema diff --git a/src/Form/FieldValue.elm b/src/Form/FieldValue.elm index f1ac028..2030308 100644 --- a/src/Form/FieldValue.elm +++ b/src/Form/FieldValue.elm @@ -1,9 +1,10 @@ module Form.FieldValue exposing - ( FieldType(..) - , FieldValue(..) + ( FieldValue(..) , asBool , asString - , fromFieldInput + , fromFloatInput + , fromIntInput + , fromStringInput , pointedFieldValue , updateValue ) @@ -20,15 +21,6 @@ type FieldValue | Int Int | Number Float | Bool Bool - | Empty - - -{-| Types that may be produced by a HTML field --} -type FieldType - = NumberField - | IntField - | StringField asString : FieldValue -> String @@ -49,37 +41,31 @@ asString fv = Bool False -> "False" - Empty -> - "" - -asValue : FieldValue -> Maybe Value +asValue : FieldValue -> Value asValue fv = case fv of String s -> - Just <| Encode.string s + Encode.string s Int i -> - Just <| Encode.int i + Encode.int i Number n -> - Just <| Encode.float n + Encode.float n Bool b -> - Just <| Encode.bool b - - Empty -> - Nothing + Encode.bool b -asBool : FieldValue -> Maybe Bool +asBool : FieldValue -> Bool asBool fv = case fv of Bool b -> - Just b + b _ -> - Nothing + False toFieldValue : Value -> Maybe FieldValue @@ -112,18 +98,12 @@ updateValue pointer new value = case pointer of "properties" :: key :: [] -> Encode.dict identity identity <| - case ( Decode.decodeValue (Decode.dict Decode.value) value, asValue new ) of - ( Ok o, Nothing ) -> - Dict.remove key o - - ( Ok o, Just v ) -> - Dict.insert key v o - - ( Err _, Nothing ) -> - Dict.empty + case Decode.decodeValue (Decode.dict Decode.value) value of + Ok o -> + Dict.insert key (asValue new) o - ( Err _, Just v ) -> - Dict.singleton key v + Err _ -> + Dict.singleton key (asValue new) "properties" :: key :: ps -> case Decode.decodeValue (Decode.dict Decode.value) value of @@ -135,7 +115,7 @@ updateValue pointer new value = Encode.dict identity identity <| Dict.singleton key (updateValue ps new Encode.null) [] -> - Maybe.withDefault Encode.null <| asValue new + asValue new _ -> value @@ -143,39 +123,14 @@ updateValue pointer new value = fromIntInput : String -> FieldValue fromIntInput s = - if String.isEmpty s then - Empty - - else - Maybe.withDefault (String s) <| Maybe.map Int <| String.toInt s + Maybe.withDefault (String s) <| Maybe.map Int <| String.toInt s fromFloatInput : String -> FieldValue fromFloatInput s = - if String.isEmpty s then - Empty - - else - Maybe.withDefault (String s) <| Maybe.map Number <| String.toFloat s + Maybe.withDefault (String s) <| Maybe.map Number <| String.toFloat s fromStringInput : String -> FieldValue fromStringInput s = - if String.isEmpty s then - Empty - - else - String s - - -fromFieldInput : FieldType -> String -> FieldValue -fromFieldInput fieldType = - case fieldType of - StringField -> - fromStringInput - - IntField -> - fromIntInput - - NumberField -> - fromFloatInput + String s diff --git a/src/Form/Normalization.elm b/src/Form/Normalization.elm new file mode 100644 index 0000000..cbd4f5e --- /dev/null +++ b/src/Form/Normalization.elm @@ -0,0 +1,51 @@ +module Form.Normalization exposing (normalizeValue) + +import Json.Decode as Decode exposing (Value) +import Json.Encode as Encode + + +{-| If decoder succeeds, return its value. Otherwise, return a default value. +-} +withDefault : Decode.Decoder Value -> Value -> Value +withDefault d v = + Result.withDefault v <| Decode.decodeValue d v + + +normalizeValue : Value -> Value +normalizeValue = + normalizeObject >> normalizeList >> normalizeString + + +{-| Trim spaces from strings +-} +normalizeString : Value -> Value +normalizeString = + withDefault (Decode.map (Encode.string << String.trim) Decode.string) + + +isEmpty : Value -> Bool +isEmpty v = + Decode.decodeValue Decode.string v == Ok "" + + +normalizeObject : Value -> Value +normalizeObject value = + let + {- Empty values are removed from objects. + + This is important to do, because we need to mark empty fields as missing, + not invalid. + -} + mapKeyValue ( k, v ) = + if isEmpty v then + Nothing + + else + Just ( k, v ) + in + withDefault (Decode.map (Encode.object << List.filterMap (mapKeyValue << Tuple.mapSecond normalizeValue)) (Decode.keyValuePairs Decode.value)) value + + +normalizeList : Value -> Value +normalizeList v = + withDefault (Decode.map (Encode.list normalizeValue) (Decode.list Decode.value)) v diff --git a/src/Form/Settings.elm b/src/Form/Settings.elm deleted file mode 100644 index 21ac671..0000000 --- a/src/Form/Settings.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Form.Settings exposing (Settings) - -import Form.Error exposing (ErrorValue) -import Form.Theme exposing (Theme) -import Json.Pointer exposing (Pointer) - - -type alias Settings = - { errors : Pointer -> ErrorValue -> String - , theme : Theme - } diff --git a/src/Form/State.elm b/src/Form/State.elm index 6051e46..2e9c979 100644 --- a/src/Form/State.elm +++ b/src/Form/State.elm @@ -1,30 +1,32 @@ module Form.State exposing - ( FieldState - , Form + ( Form , FormState , Msg(..) - , fieldState + , ValidateWidgets(..) + , getErrorAt , initState , updateState + , validateWidget ) import Dict exposing (Dict) import Form.Error exposing (ErrorValue, Errors) -import Form.FieldValue as FieldValue exposing (FieldValue(..)) -import Form.Settings exposing (Settings) +import Form.FieldValue as FieldValue exposing (FieldValue) import Json.Decode exposing (Value) import Json.Pointer exposing (Pointer) import Json.Schema.Definitions exposing (Schema) +import Set exposing (Set) +import UiSchema as UI import UiSchema.Internal exposing (UiSchema) import Validation exposing (Validation) type alias Form = - { settings : Settings - , schema : Schema + { schema : Schema , uiSchema : UiSchema , uiSchemaIsGenerated : Bool , state : FormState + , defaultOptions : UI.DefOptions } @@ -34,25 +36,48 @@ type alias FormState = , focus : Maybe Pointer , errors : Errors , categoryFocus : Dict (List Int) Int + , validateWidgets : ValidateWidgets } -type alias FieldState = - { formId : String - , pointer : Pointer - , value : FieldValue - , error : Maybe ErrorValue - , hasFocus : Bool - , disabled : Bool - , required : Bool - } +{-| Controls which widgets should show validation errors. + +All - all widgets should show validation errors. Used after a form submission attempt. + +Listed - only widgets in the set should show validation errors. +Widgets are added to the set when their value is updated. + +-} +type ValidateWidgets + = All + | Listed (Set Pointer) type Msg = Focus Pointer - | Blur | Input Pointer FieldValue | FocusCategory (List Int) Int + | ValidateAll + + +validateWidgetsMap : (Set Pointer -> Set Pointer) -> ValidateWidgets -> ValidateWidgets +validateWidgetsMap f vw = + case vw of + All -> + All + + Listed set -> + Listed (f set) + + +validateWidget : Pointer -> ValidateWidgets -> Bool +validateWidget pointer vw = + case vw of + All -> + True + + Listed set -> + Set.member pointer set initState : String -> Value -> (Value -> Validation output) -> FormState @@ -64,35 +89,29 @@ initState formId initialValue validation = , focus = Nothing , errors = [] , categoryFocus = Dict.empty + , validateWidgets = Listed Set.empty } in updateValidations validation model -fieldState : Bool -> Bool -> Pointer -> FormState -> FieldState -fieldState disabled required pointer form = - { formId = form.formId - , pointer = pointer - , value = Maybe.withDefault Empty <| FieldValue.pointedFieldValue pointer form.value - , error = getErrorAt pointer form.errors - , hasFocus = form.focus == Just pointer - , disabled = disabled - , required = required - } - - updateState : (Value -> Validation output) -> Msg -> FormState -> FormState updateState validation msg model = case msg of Focus pointer -> - { model | focus = Just pointer } + { model + | focus = Just pointer + } - Blur -> - updateValidations validation { model | focus = Nothing } + ValidateAll -> + { model | validateWidgets = All } Input pointer fieldValue -> updateValidations validation - { model | value = FieldValue.updateValue pointer fieldValue model.value } + { model + | value = FieldValue.updateValue pointer fieldValue model.value + , validateWidgets = validateWidgetsMap (Set.insert pointer) model.validateWidgets + } FocusCategory uiState ix -> updateValidations validation { model | categoryFocus = Dict.insert uiState ix model.categoryFocus } diff --git a/src/Form/Theme.elm b/src/Form/Theme.elm deleted file mode 100644 index deffe1b..0000000 --- a/src/Form/Theme.elm +++ /dev/null @@ -1,213 +0,0 @@ -module Form.Theme exposing (Theme, simpleTailwind, scrive) - -{-| Form appearance - -@docs Theme, simpleTailwind, scrive - --} - -import Html exposing (Attribute) -import Html.Attributes as Attrs - - -{-| Form appearance definition --} -type alias Theme = - { horizontalLayout : { cols : Int } -> Attribute Never - , horizontalLayoutItem : Attribute Never - , groupLabel : Attribute Never - , label : Attribute Never - , categorizationMenu : Attribute Never - , categorizationMenuItem : { focus : Bool } -> Attribute Never - , fieldGroup : Attribute Never - , fieldLabel : Attribute Never - , fieldDescription : Attribute Never - , fieldError : Attribute Never - , checkboxRow : Attribute Never - , radioEntry : { vertical : Bool } -> Attribute Never - , textInput : { trim : Bool, invalid : Bool } -> Attribute Never - , textArea : { trim : Bool, invalid : Bool } -> Attribute Never - , selectInput : { trim : Bool, invalid : Bool } -> Attribute Never - , checkboxInput : { invalid : Bool } -> Attribute Never - , radioInput : Attribute Never - , sliderInput : Attribute Never - , sliderWithTicks : { trim : Bool } -> Attribute Never - , toggleInput : { checked : Bool } -> Attribute Never - , toggleKnob : { checked : Bool } -> Attribute Never - , group : Attribute Never - , disabledElems : Attribute Never - } - - -{-| Simple form styling using Tailwind - -This theme is as simple as possible while also having acceptable styling. - --} -simpleTailwind : Theme -simpleTailwind = - { horizontalLayout = \{ cols } -> Attrs.class ("grid gap-3 grid-cols-" ++ String.fromInt cols) - , horizontalLayoutItem = Attrs.class "" - , label = Attrs.class "font-bold mt-4" - , groupLabel = Attrs.class "font-bold" - , categorizationMenu = Attrs.class "my-4 border-b" - , categorizationMenuItem = - \{ focus } -> - Attrs.classList - [ ( "p-4 pb-2", True ) - , ( "text-blue-500 border-b-2 border-blue-500", focus ) - , ( "", not focus ) - ] - , fieldGroup = Attrs.class "my-4" - , fieldLabel = Attrs.class "block text-sm my-1" - , fieldDescription = Attrs.class "text-sm text-slate-500 my-1" - , fieldError = Attrs.class "text-red-600 text-xs my-1" - , checkboxRow = Attrs.class "flex items-center space-x-4" - , radioEntry = - \{ vertical } -> - Attrs.classList - [ ( "mr-5 items-center", True ) - , ( "flex", vertical ) - ] - , textInput = - \{ trim, invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - , ( "w-full", not trim ) - ] - , textArea = - \{ trim, invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - , ( "w-full", not trim ) - ] - , selectInput = - \{ trim, invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - , ( "w-full", not trim ) - ] - , checkboxInput = - \{ invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - ] - , radioInput = - Attrs.classList - [ ( "mr-3", True ) - ] - , sliderInput = - Attrs.class "w-full" - , sliderWithTicks = - \{ trim } -> - Attrs.classList - [ ( "w-52", trim ) - ] - , toggleInput = - \{ checked } -> - Attrs.classList - [ ( "inline-flex w-11 rounded-full border-2 border-transparent transition-colors duration-200 ease-in-out focus:outline-none focus:ring-2 focus:ring-blue-500 focus:ring-offset-2", True ) - , ( "bg-gray-300", not checked ) - , ( "bg-blue-500", checked ) - ] - , toggleKnob = - \{ checked } -> - Attrs.classList - [ ( "pointer-events-none h-5 w-5 rounded-full bg-white shadow transition duration-200 ease-in-out", True ) - , ( "translate-x-0", not checked ) - , ( "translate-x-5", checked ) - ] - , group = Attrs.class "border border-gray-300 p-3 my-3" - , disabledElems = Attrs.class "opacity-50" - } - - -{-| Simple form styling using Tailwind - -This theme is as simple as possible while also having acceptable styling. - --} -scrive : Theme -scrive = - { horizontalLayout = \{ cols } -> Attrs.class ("grid gap-3 grid-cols-" ++ String.fromInt cols) - , horizontalLayoutItem = Attrs.class "" - , label = Attrs.class "font-bold mt-4" - , groupLabel = Attrs.class "font-bold" - , categorizationMenu = Attrs.class "my-4 border-b" - , categorizationMenuItem = - \{ focus } -> - Attrs.classList - [ ( "p-4 pb-2", True ) - , ( "text-blue-500 border-b-2 border-blue-500", focus ) - , ( "", not focus ) - ] - , fieldGroup = Attrs.class "my-4" - , fieldLabel = Attrs.class "block text-sm font-medium mb-1" - , fieldDescription = Attrs.class "text-sm text-slate-500 my-1" - , fieldError = Attrs.class "text-red-600 text-xs my-1" - , checkboxRow = Attrs.class "flex gap-3" - , radioEntry = - \{ vertical } -> - Attrs.classList - [ ( "mr-5", True ) - , ( "flex", vertical ) - ] - , textInput = - \{ trim, invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - , ( "border-gray-700", not invalid ) - , ( "w-full", not trim ) - , ( "w-52", trim ) - , ( "border py-2 px-3 text-sm rounded", True ) - ] - , textArea = - \{ trim, invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - , ( "border-gray-700", not invalid ) - , ( "w-full", not trim ) - , ( "w-52", trim ) - , ( "border py-2 px-3 text-sm rounded", True ) - ] - , selectInput = - \{ trim, invalid } -> - Attrs.classList - [ ( "border-red-600", invalid ) - , ( "border-gray-700", not invalid ) - , ( "w-full", not trim ) - , ( "w-52", trim ) - , ( "border py-2 px-3 text-sm rounded bg-white", True ) - ] - , checkboxInput = - \_ -> - Attrs.classList - [ ( "border-gray-500", True ) -- "border-scrive-gray" eqivalent - , ( "border-2 w-5 h-5", True ) - ] - , radioInput = - Attrs.class "border-gray-500 border-2 w-4 h-4 mr-3" - , sliderInput = - Attrs.class "w-full" - , sliderWithTicks = - \{ trim } -> - Attrs.classList - [ ( "w-52", trim ) - ] - , toggleInput = - \{ checked } -> - Attrs.classList - [ ( "inline-flex w-11 rounded-full border-2 border-transparent transition-colors duration-200 ease-in-out focus:outline-none focus:ring-2 focus:ring-blue-500 focus:ring-offset-2", True ) - , ( "bg-gray-300", not checked ) - , ( "bg-blue-500", checked ) - ] - , toggleKnob = - \{ checked } -> - Attrs.classList - [ ( "pointer-events-none h-5 w-5 rounded-full bg-white shadow transition duration-200 ease-in-out", True ) - , ( "translate-x-0", not checked ) - , ( "translate-x-5", checked ) - ] - , group = Attrs.class "border border-gray-300 p-3 my-3" - , disabledElems = Attrs.class "opacity-50" - } diff --git a/src/Form/Validation.elm b/src/Form/Validation.elm index 521f7a2..3d098e5 100644 --- a/src/Form/Validation.elm +++ b/src/Form/Validation.elm @@ -1,6 +1,7 @@ -module Form.Validation exposing (validation) +module Form.Validation exposing (validate) import Form.Error as Error exposing (ErrorValue(..)) +import Form.Normalization exposing (normalizeValue) import Form.Regex import Json.Decode as Decode exposing (Value) import Json.Encode as Encode @@ -18,22 +19,36 @@ import Set import Validation exposing (Validation, error) -validation : Schema -> Value -> Validation Value -validation schema value = - case schema of - BooleanSchema bool -> - if bool then - Validation.succeed value +validate : Schema -> Value -> Validation Value +validate schema rawValue = + let + value = + normalizeValue rawValue + in + Validation.voidRight value <| validateSchema schema value + + +validateSchema : Schema -> Value -> Validation Value +validateSchema schema rawValue = + let + value = + normalizeValue rawValue + in + Validation.voidRight value <| + case schema of + BooleanSchema bool -> + if bool then + Validation.succeed value - else - Validation.fail (error <| Unimplemented "Boolean schemas are not implemented.") + else + Validation.fail (error <| Unimplemented "Boolean schemas are not implemented.") - ObjectSchema objectSchema -> - subSchema objectSchema value + ObjectSchema objectSchema -> + validateSubSchema objectSchema value -subSchema : SubSchema -> Value -> Validation Value -subSchema schema = +validateSubSchema : SubSchema -> Value -> Validation Value +validateSubSchema schema = let typeValidations : Value -> Validation Value typeValidations = @@ -84,7 +99,7 @@ validateSingleType schema type_ value = Ok Encode.null ( Just val, _ ) -> - validation propSchema val + validateSchema propSchema val in Validation.validateAll (List.map (\( key, propSchema ) _ -> validateKey key propSchema) propList) value diff --git a/src/Form/View.elm b/src/Form/View.elm deleted file mode 100644 index ae3ae92..0000000 --- a/src/Form/View.elm +++ /dev/null @@ -1,501 +0,0 @@ -module Form.View exposing (view) - -import Dict -import Form.Error exposing (ErrorValue) -import Form.FieldValue as FieldValue exposing (FieldType(..)) -import Form.Settings exposing (Settings) -import Form.State as F exposing (Form, FormState, Msg(..)) -import Form.Theme exposing (Theme) -import Form.View.Input as Input exposing (Input) -import Html exposing (Html, button, div, label, span, text) -import Html.Attributes as Attrs -import Html.Attributes.Extra as Attrs -import Html.Events exposing (..) -import Html.Extra as Html -import Json.Decode as Decode -import Json.Encode as Encode -import Json.Pointer as Pointer exposing (Pointer) -import Json.Schema.Definitions exposing (Schema(..), SingleType(..), SubSchema, Type(..)) -import Json.Util as Util -import List.Extra as List -import Maybe.Extra as Maybe -import UiSchema.Internal as UI exposing (UiSchema) -import UiSchema.Rule as Rule - - -type alias UiState = - { disabled : Bool - , uiPath : List Int - , uiSchema : UiSchema - } - - -walkState : Int -> UiSchema -> UiState -> UiState -walkState i uiSchema st = - { st | uiPath = List.append st.uiPath [ i ], uiSchema = uiSchema } - - -view : Form -> UiState -> List (Html F.Msg) -view form uiState = - let - ruleEffect : Maybe Rule.AppliedEffect - ruleEffect = - Rule.computeRule form.state.value (UI.getRule uiState.uiSchema) - - newUiState = - { uiState | disabled = ruleEffect == Just Rule.Disabled } - in - maybeHide ruleEffect <| - case uiState.uiSchema of - UI.UiControl c -> - [ controlView form.settings newUiState form.schema c form.state ] - - UI.UiHorizontalLayout hl -> - horizontalLayoutView form newUiState hl - - UI.UiVerticalLayout vl -> - verticalLayoutView form newUiState vl - - UI.UiGroup g -> - groupView form newUiState g - - UI.UiCategorization c -> - categorizationView form newUiState c - - UI.UiLabel l -> - [ Html.div [ Attrs.map never form.settings.theme.label ] [ text l.text ] ] - - -maybeHide : Maybe Rule.AppliedEffect -> List (Html F.Msg) -> List (Html F.Msg) -maybeHide effect x = - case effect of - Just Rule.Hidden -> - [] - - Just Rule.Disabled -> - x - - Nothing -> - x - - -horizontalLayoutView : Form -> UiState -> UI.HorizontalLayout -> List (Html F.Msg) -horizontalLayoutView form uiState hl = - [ div [ Attrs.map never <| form.settings.theme.horizontalLayout { cols = List.length hl.elements } ] <| - List.indexedMap - (\ix us -> - div - [ Attrs.map never form.settings.theme.horizontalLayoutItem ] - (view form (walkState ix us uiState)) - ) - hl.elements - ] - - -verticalLayoutView : Form -> UiState -> UI.VerticalLayout -> List (Html F.Msg) -verticalLayoutView form uiState vl = - List.indexedMap - (\ix us -> - div - [] - (view form (walkState ix us uiState)) - ) - vl.elements - - -groupView : Form -> UiState -> UI.Group -> List (Html F.Msg) -groupView form uiState group = - let - title = - Maybe.unwrap [] (\l -> [ Html.div [ Attrs.map never form.settings.theme.groupLabel ] [ text l ] ]) group.label - - contents = - verticalLayoutView form uiState { elements = group.elements, rule = group.rule } - in - [ div [ Attrs.map never form.settings.theme.group ] (title ++ contents) - ] - - -onClickPreventDefault : msg -> Html.Attribute msg -onClickPreventDefault msg = - preventDefaultOn "click" - (Decode.succeed ( msg, True )) - - -categorizationView : Form -> UiState -> UI.Categorization -> List (Html F.Msg) -categorizationView form uiState categorization = - let - focusedCategoryIx = - Maybe.withDefault 0 <| Dict.get uiState.uiPath form.state.categoryFocus - - categoryButton ix cat = - if Rule.computeRule form.state.value cat.rule == Just Rule.Hidden then - Nothing - - else - Just <| - button - [ Attrs.map never <| form.settings.theme.categorizationMenuItem { focus = focusedCategoryIx == ix } - , onClickPreventDefault <| F.FocusCategory uiState.uiPath ix - ] - [ text cat.label ] - - categoryUiState cat = - walkState focusedCategoryIx (UI.UiVerticalLayout { elements = cat.elements, rule = cat.rule }) uiState - in - div - [ Attrs.map never form.settings.theme.categorizationMenu - ] - (Maybe.values <| List.indexedMap categoryButton categorization.elements) - :: Maybe.unwrap [] (\cat -> view form (categoryUiState cat)) (List.getAt focusedCategoryIx categorization.elements) - - -{-| Approximate whether a control is required to display asterix in the label --} -isRequired : Schema -> Pointer -> Bool -isRequired wholeSchema pointer = - let - parentSchema = - UI.pointToSchema wholeSchema (List.take (List.length pointer - 2) pointer) - in - case ( parentSchema, List.last pointer ) of - ( Just (ObjectSchema schema), Just prop ) -> - case schema.type_ of - SingleType ObjectType -> - List.any ((==) prop) (Maybe.withDefault [] schema.required) - - _ -> - False - - _ -> - False - - -controlView : Settings -> UiState -> Schema -> UI.Control -> FormState -> Html F.Msg -controlView settings uiState wholeSchema control form = - let - controlSchema = - UI.pointToSchema wholeSchema control.scope - - defOptions = - UI.applyDefaults control.options - - disabled = - defOptions.readonly == True || uiState.disabled - - required = - isRequired wholeSchema control.scope - - fieldState = - F.fieldState disabled required control.scope form - - controlBody schema_ = - Util.withObjectSchema Html.nothing schema_ <| - \schema -> - case schema.type_ of - SingleType IntegerType -> - textLikeInput settings control defOptions schema IntField fieldState - - SingleType NumberType -> - textLikeInput settings control defOptions schema NumberField fieldState - - SingleType StringType -> - textLikeInput settings control defOptions schema StringField fieldState - - SingleType BooleanType -> - checkbox settings control defOptions schema fieldState - - _ -> - Html.nothing - in - Html.viewMaybe - (\cs -> - div - [ Attrs.id (Input.inputElementGroupId form.formId (Pointer.toString control.scope)) - , Attrs.map never settings.theme.fieldGroup - , if fieldState.disabled then - Attrs.map never settings.theme.disabledElems - - else - Attrs.empty - ] - [ controlBody cs ] - ) - controlSchema - - -textLikeInput : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> FieldType -> Input -textLikeInput settings control defOptions schema fieldType state = - if schema.enum /= Nothing then - if defOptions.format == Just UI.Radio then - radioGroup settings control defOptions schema fieldType state - - else - select settings control defOptions schema fieldType state - - else if defOptions.slider == True then - slider settings control defOptions schema fieldType state - - else if defOptions.multi && fieldType == StringField then - textarea settings control defOptions schema state - - else - textInput settings control defOptions schema fieldType state - - -textInput : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> FieldType -> Input -textInput settings control defOptions schema fieldType fieldState = - let - inputType : String - inputType = - case fieldType of - StringField -> - case schema.format of - Just "email" -> - "email" - - Just "idn-email" -> - "email" - - Just "date" -> - "date" - - Just "time" -> - "time" - - Just "date-time" -> - "datetime-local" - - Just "month" -> - "month" - - Just "week" -> - "week" - - Just "hostname" -> - "url" - - Just "idn-hostname" -> - "url" - - Just "uri" -> - "url" - - Just "iri" -> - "url" - - _ -> - "text" - - NumberField -> - "number" - - IntField -> - "number" - in - fieldGroup (Input.baseTextInput settings defOptions fieldType inputType schema.maxLength fieldState) - settings - { showLabel = True } - control - defOptions - schema - fieldState - - -slider : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> FieldType -> Input -slider settings control defOptions schema fieldType fieldState = - fieldGroup (Input.slider settings defOptions schema fieldType fieldState) - settings - { showLabel = True } - control - defOptions - schema - fieldState - - -textarea : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> Input -textarea settings control defOptions schema state = - fieldGroup - (Input.textArea settings defOptions schema.maxLength state) - settings - { showLabel = True } - control - defOptions - schema - state - - -select : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> FieldType -> F.FieldState -> Html F.Msg -select settings control defOptions schema fieldType fieldState = - let - values : List String - values = - Maybe.toList schema.enum |> List.concat |> List.map (Decode.decodeValue UI.decodeStringLike >> Result.withDefault "") |> List.append [ "" ] - - items : List ( String, String ) - items = - List.map (\v -> ( v, v )) values - in - fieldGroup - (Input.baseSelectInput fieldType settings items fieldState) - settings - { showLabel = True } - control - defOptions - schema - fieldState - - -radioGroup : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> FieldType -> Input -radioGroup settings control defOptions schema fieldType fieldState = - let - values : List String - values = - Maybe.toList schema.enum |> List.concat |> List.map (Decode.decodeValue UI.decodeStringLike >> Result.withDefault "") - - elementId = - Input.inputElementId fieldState.formId fieldState.pointer - - radio value = - let - optionElementId = - elementId ++ "-" ++ value - in - label [ Attrs.for optionElementId, Attrs.map never <| settings.theme.radioEntry { vertical = defOptions.orientation == UI.Vertical } ] - [ Html.input - [ Attrs.type_ "radio" - , Attrs.id optionElementId - , Attrs.name elementId - , Attrs.checked <| value == FieldValue.asString fieldState.value - , Attrs.map never settings.theme.radioInput - , onClick (Input fieldState.pointer (FieldValue.fromFieldInput fieldType value)) - , onFocus (Focus fieldState.pointer) - , onBlur Blur - , Attrs.disabled fieldState.disabled - ] - [] - , span [ Attrs.map never settings.theme.fieldLabel ] [ text value ] - ] - in - fieldGroup - (div [] (List.map radio values)) - settings - { showLabel = True } - control - defOptions - schema - fieldState - - -checkbox : Settings -> UI.Control -> UI.DefOptions -> SubSchema -> Input -checkbox settings control defOptions schema fieldState = - let - required : Bool - required = - schema.const == Just (Encode.bool True) - - inputField : Html F.Msg - inputField = - div [ Attrs.map never settings.theme.checkboxRow ] - [ if (control.options |> Maybe.andThen .toggle) == Just True then - Input.toggleInput settings fieldState - - else - Input.checkboxInput settings fieldState - , Html.viewMaybe identity <| fieldLabel settings.theme control.label defOptions schema control.scope required - ] - in - fieldGroup - inputField - settings - { showLabel = False } - control - defOptions - schema - fieldState - - -fieldGroup : Html F.Msg -> Settings -> { showLabel : Bool } -> UI.Control -> UI.DefOptions -> SubSchema -> Input -fieldGroup inputField settings { showLabel } control defOptions schema fieldState = - let - label_ : Maybe (Html F.Msg) - label_ = - if showLabel then - fieldLabel settings.theme control.label defOptions schema control.scope fieldState.required - - else - Nothing - - showDescription = - defOptions.showUnfocusedDescription == True || fieldState.hasFocus - - description : Html F.Msg - description = - Html.viewMaybe identity <| - if showDescription then - fieldDescription settings.theme schema - - else - Nothing - - errorMessage : Html F.Msg - errorMessage = - Html.viewMaybe identity <| error settings.theme settings.errors fieldState - in - label [ Attrs.for (Input.inputElementId fieldState.formId fieldState.pointer) ] - [ Html.viewMaybe identity label_ - , inputField - , description - , errorMessage - ] - - -fieldLabel : Theme -> Maybe UI.ControlLabel -> UI.DefOptions -> SubSchema -> Pointer -> Bool -> Maybe (Html F.Msg) -fieldLabel theme label options schema scope required = - let - fallback = - schema.title - |> Maybe.orElse (List.last scope |> Maybe.map UI.fieldNameToTitle) - |> Maybe.withDefault "" - - render str = - span [ Attrs.map never theme.fieldLabel ] - [ text - (if not options.hideRequiredAsterisk && required then - str ++ " *" - - else - str - ) - ] - in - case label of - Just (UI.StringLabel s) -> - Just <| render s - - Just (UI.BoolLabel False) -> - Nothing - - Just (UI.BoolLabel True) -> - Just <| render fallback - - Nothing -> - Just <| render fallback - - -fieldDescription : Theme -> SubSchema -> Maybe (Html F.Msg) -fieldDescription theme schema = - schema.description - |> Maybe.map (\str -> div [ Attrs.map never theme.fieldDescription ] [ text str ]) - - -error : Theme -> (Pointer -> ErrorValue -> String) -> F.FieldState -> Maybe (Html F.Msg) -error theme func f = - f.error - |> Maybe.map - (\err -> - div - [ Attrs.map never theme.fieldError - ] - [ text (func f.pointer err) ] - ) diff --git a/src/Form/View/Input.elm b/src/Form/View/Input.elm deleted file mode 100644 index 5707ca4..0000000 --- a/src/Form/View/Input.elm +++ /dev/null @@ -1,225 +0,0 @@ -module Form.View.Input exposing - ( Input - , baseSelectInput - , baseTextInput - , checkboxInput - , inputElementGroupId - , inputElementId - , slider - , textArea - , toggleInput - ) - -import Form.FieldValue as FieldValue exposing (FieldType, FieldValue(..)) -import Form.Settings exposing (Settings) -import Form.State exposing (FieldState, Msg(..)) -import Html exposing (..) -import Html.Attributes as Attrs exposing (..) -import Html.Attributes.Extra as Attrs -import Html.Events exposing (..) -import Json.Decode as Decode -import Json.Pointer as Pointer exposing (Pointer) -import Json.Schema.Definitions as Schema -import UiSchema.Internal exposing (DefOptions) - - -type alias Input = - FieldState -> Html Msg - - -baseTextInput : Settings -> DefOptions -> FieldType -> String -> Maybe Int -> Input -baseTextInput settings options fieldType inputType maxLength state = - let - formAttrs = - [ id (inputElementId state.formId state.pointer) - , type_ inputType - , value (FieldValue.asString state.value) - , onInput (FieldValue.fromFieldInput fieldType >> Input state.pointer) - , onFocus (Focus state.pointer) - , onBlur Blur - , case ( options.restrict, maxLength ) of - ( True, Just n ) -> - Attrs.maxlength n - - _ -> - Attrs.empty - , Attrs.disabled state.disabled - , Attrs.map never <| - settings.theme.textInput - { trim = options.trim - , invalid = state.error /= Nothing - } - ] - in - input formAttrs [] - - -slider : Settings -> DefOptions -> Schema.SubSchema -> FieldType -> Input -slider settings options schema fieldType state = - let - step = - Maybe.withDefault 1.0 schema.multipleOf - - minimum = - Maybe.withDefault 1.0 schema.minimum - - maximum = - Maybe.withDefault 10.0 schema.maximum - - minLimit = - case schema.exclusiveMinimum of - Just (Schema.BoolBoundary False) -> - minimum - - Just (Schema.BoolBoundary True) -> - minimum + step - - Just (Schema.NumberBoundary x) -> - x + step - - _ -> - minimum - - maxLimit = - case schema.exclusiveMaximum of - Just (Schema.BoolBoundary True) -> - maximum - step - - Just (Schema.NumberBoundary x) -> - x - step - - _ -> - maximum - - formAttrs = - [ id <| Pointer.toString state.pointer - , type_ "range" - , value (FieldValue.asString state.value) - , onInput (FieldValue.fromFieldInput fieldType >> Input state.pointer) - , onFocus (Focus state.pointer) - , onBlur Blur - , Attrs.attribute "min" (String.fromFloat minLimit) - , Attrs.attribute "max" (String.fromFloat maxLimit) - , Attrs.attribute "step" (String.fromFloat step) - , Attrs.disabled state.disabled - , Attrs.map never settings.theme.sliderInput - ] - in - div - [ Attrs.map never <| - settings.theme.sliderWithTicks - { trim = options.trim - } - ] - [ div [ Attrs.style "display" "flex", Attrs.class "text-sm" ] - [ span [ Attrs.style "flex-grow" "1", Attrs.class "text-left" ] [ text (String.fromFloat minLimit) ] - , span [ Attrs.style "flex-grow" "1", Attrs.class "text-right" ] [ text (String.fromFloat maxLimit) ] - ] - , input formAttrs [] - ] - - -textArea : Settings -> DefOptions -> Maybe Int -> Input -textArea settings options maxLength state = - let - formAttrs = - [ id <| Pointer.toString state.pointer - , value (FieldValue.asString state.value) - , onInput (String >> Input state.pointer) - , onFocus (Focus state.pointer) - , onBlur Blur - , attribute "rows" "4" - , Attrs.disabled state.disabled - , case ( options.restrict, maxLength ) of - ( True, Just n ) -> - Attrs.maxlength n - - _ -> - Attrs.empty - , Attrs.map never <| - settings.theme.textArea - { trim = options.trim - , invalid = state.error /= Nothing - } - ] - in - Html.textarea formAttrs [] - - -baseSelectInput : FieldType -> Settings -> List ( String, String ) -> Input -baseSelectInput fieldType settings valueList state = - let - formAttrs = - [ id (inputElementId state.formId state.pointer) - , on - "change" - (targetValue |> Decode.map (FieldValue.fromFieldInput fieldType >> Input state.pointer)) - , onFocus (Focus state.pointer) - , onBlur Blur - , Attrs.disabled state.disabled - , Attrs.map never <| - settings.theme.selectInput - { trim = False - , invalid = state.error /= Nothing - } - ] - - buildOption ( k, v ) = - option [ value k, selected (FieldValue.asString state.value == k) ] [ text v ] - in - select formAttrs (List.map buildOption valueList) - - -inputElementId : String -> Pointer -> String -inputElementId formId pointer = - formId ++ "-" ++ Pointer.toString pointer ++ "-input" - - -inputElementGroupId : String -> String -> String -inputElementGroupId formId path = - formId ++ "-" ++ path - - -toggleInput : Settings -> Input -toggleInput settings state = - let - checked = - if state.value == Bool True then - True - - else - False - - formAttrs = - [ type_ "button" - , Attrs.id (inputElementId state.formId state.pointer) - , Attrs.map never <| settings.theme.toggleInput { checked = checked } - , onClick (Input state.pointer (Bool <| not checked)) - , onFocus (Focus state.pointer) - , onBlur Blur - , Attrs.disabled state.disabled - ] - in - button formAttrs - [ span - [ Attrs.map never <| settings.theme.toggleKnob { checked = checked } - ] - [] - ] - - -checkboxInput : Settings -> Input -checkboxInput settings state = - let - formAttrs = - [ type_ "checkbox" - , Attrs.id (inputElementId state.formId state.pointer) - , Attrs.map never <| settings.theme.checkboxInput { invalid = state.error /= Nothing } - , checked (FieldValue.asBool state.value |> Maybe.withDefault False) - , onCheck (Bool >> Input state.pointer) - , onFocus (Focus state.pointer) - , onBlur Blur - , Attrs.disabled state.disabled - ] - in - input formAttrs [] diff --git a/src/Form/Widget.elm b/src/Form/Widget.elm new file mode 100644 index 0000000..3160c64 --- /dev/null +++ b/src/Form/Widget.elm @@ -0,0 +1,224 @@ +module Form.Widget exposing (Widget(..), Group, Categorization, CategoryButton, Label, Options, Validation(..), isInvalid, Control(..), TextInput, FieldFormat(..), FieldType(..), TextArea, Select, RadioGroup, Checkbox, Slider) + +{-| Abstract form view representation. + +This representation is meant to be rendered into HTML. For inspiration, see the +[`Form.Widget.View`](https://github.com/scrive/elm-json-forms/blob/main/src/Form/Widget/View.elm) module. + +@docs Widget, Group, Categorization, CategoryButton, Label, Options, Validation, isInvalid, Control, TextInput, FieldFormat, FieldType, TextArea, Select, RadioGroup, Checkbox, Slider + +-} + +import Form.Error exposing (ErrorValue) +import Form.State exposing (Msg) + + +{-| Root of the form representation. + +Widgets can be nested to create complex forms. + +-} +type Widget + = WHorizontalLayout (List Widget) + | WVerticalLayout (List Widget) + | WGroup Group + | WCategorization Categorization + | WLabel Label + | WControl Options Control + + +{-| Label element. +-} +type alias Label = + String + + +{-| Labeled group of elements. + +Elements in a group are rendered vertically, below the group label. + +-} +type alias Group = + { label : Maybe String + , elements : List Widget + } + + +{-| Categorization element. + +A categorization element consists of a list of category buttons, +and a list of elements from the chosen category. + +`elements` list contains the active category elements, +which should be rendered vertically below category buttons. + +-} +type alias Categorization = + { buttons : List CategoryButton + , elements : List Widget + } + + +{-| Category button. + +A category button is a button that can be clicked to select the active category. + +Active category is marked with the `focus` attribute. + +-} +type alias CategoryButton = + { label : String + , focus : Bool + , onClick : Msg + } + + +{-| Control options + +Controls should be rendered in accordance with these options. + + - `label` - Label of the control, to be shown above the control. + - `hideLabel` - Whether the label should be hidden. + If `True`, the `aria-label` attribute should be filled with the `label` value. + - `id` - Unique identifier for the control, to be used as the "id" attribute. + - `required` - Whether the control should be marked as required, with an asterisk or similar. + Note that the control may or may not _actually_ be required. + - `validation` - Validation state of the control, possibly containing an error value. + - `description` - Description of the control, to be shown below the control. + - `onFocus` - Used only to show field descriptions on focus. + If this feature is not used, the `onFocus` message does not need to be triggered. + - `trim` - Whether the control should be short + +-} +type alias Options = + { label : String + , hideLabel : Bool + , id : String + , disabled : Bool + , required : Bool + , validation : Validation + , description : Maybe String + , onFocus : Msg + , trim : Bool + } + + +{-| Validation state of a field. + +To avoid showing many validation errors for a freshly-displayed form, +the validation state is `NotValidated` until the field is focused, or +until the `validateAllFieldsMsg` message is sent. + +-} +type Validation + = NotValidated + | Valid + | Invalid ErrorValue + + +{-| Convenience function to check if a validation state is invalid. + +If so, the associated error value should be rendered. + +-} +isInvalid : Validation -> Bool +isInvalid validation = + case validation of + Invalid _ -> + True + + _ -> + False + + +{-| Specific kind of a control element with associated options. +-} +type Control + = CTextInput TextInput + | CTextArea TextArea + | CSelect Select + | CRadioGroup RadioGroup + | CCheckbox Checkbox + | CSlider Slider + + +{-| Text input control + +`maxLength` should inform the "maxlength" attribute of the input field. + +-} +type alias TextInput = + { value : String + , fieldType : FieldType + , maxLength : Maybe Int + , onInput : String -> Msg + } + + +{-| Type of a text-like input field +-} +type FieldType + = NumberField + | IntField + | StringField FieldFormat + + +{-| Format of a string field +-} +type FieldFormat + = Text + | Email + | Date + | Time + | DateTime + | Phone + + +{-| Text area control + +`maxLength` should inform the "maxlength" attribute of the input field. + +-} +type alias TextArea = + { value : String + , maxLength : Maybe Int + , onInput : String -> Msg + } + + +{-| Select control. +-} +type alias Select = + { valueList : List { label : String, selected : Bool } + , onChange : String -> Msg + } + + +{-| Radio group control. +-} +type alias RadioGroup = + { valueList : List { id : String, label : String, checked : Bool, onClick : Msg } + , vertical : Bool + } + + +{-| Checkbox control +-} +type alias Checkbox = + { value : Bool + , onCheck : Bool -> Msg + } + + +{-| Slider control. + +This element is implemented for completeness, but there are probably not many use-cases for it. + +-} +type alias Slider = + { value : String + , min : String + , max : String + , step : String + , onInput : String -> Msg + } diff --git a/src/Form/Widget/Generate.elm b/src/Form/Widget/Generate.elm new file mode 100644 index 0000000..557d0fa --- /dev/null +++ b/src/Form/Widget/Generate.elm @@ -0,0 +1,450 @@ +module Form.Widget.Generate exposing (widget) + +import Dict +import Form.FieldValue as FieldValue exposing (FieldValue, fromFloatInput, fromIntInput, fromStringInput) +import Form.State as F exposing (Form, FormState, Msg(..), validateWidget) +import Form.Widget exposing (..) +import Json.Decode as Decode +import Json.Encode as Encode +import Json.Pointer as Pointer exposing (Pointer) +import Json.Schema.Definitions as Schema exposing (Schema, SingleType(..), SubSchema, Type(..)) +import List.Extra as List +import Maybe.Extra as Maybe +import UiSchema.Internal as UI exposing (UiSchema) +import UiSchema.Rule as Rule + + +type alias UiState = + { disabled : Bool + , uiPath : List Int + , uiSchema : UiSchema + } + + +walkState : Int -> UiSchema -> UiState -> UiState +walkState i uiSchema st = + { st | uiPath = List.append st.uiPath [ i ], uiSchema = uiSchema } + + +widget : Form -> Widget +widget form = + Maybe.withDefault + (WVerticalLayout []) + (goWidget form { uiPath = [], disabled = False, uiSchema = form.uiSchema }) + + +goWidget : Form -> UiState -> Maybe Widget +goWidget form uiState = + let + ruleEffect : Maybe Rule.AppliedEffect + ruleEffect = + Rule.computeRule form.state.value (UI.getRule uiState.uiSchema) + + newUiState = + { uiState | disabled = ruleEffect == Just Rule.Disabled } + in + Maybe.andThen (maybeHide ruleEffect) <| + case uiState.uiSchema of + UI.UiHorizontalLayout hl -> + Just <| horizontalLayoutWidget form newUiState hl + + UI.UiVerticalLayout vl -> + Just <| verticalLayoutWidget form newUiState vl + + UI.UiGroup g -> + Just <| groupWidget form newUiState g + + UI.UiControl c -> + Maybe.andThen + (\subSchema -> + controlWidget form.defaultOptions newUiState form.schema subSchema c form.state + ) + <| + UI.pointToSubSchema form.schema c.scope + + UI.UiCategorization c -> + Just <| categorizationWidget form newUiState c + + UI.UiLabel l -> + Just <| labelWidget l + + +maybeHide : Maybe Rule.AppliedEffect -> Widget -> Maybe Widget +maybeHide effect x = + case effect of + Just Rule.Hidden -> + Nothing + + Just Rule.Disabled -> + Just x + + Nothing -> + Just x + + +horizontalLayoutWidget : Form -> UiState -> UI.HorizontalLayout -> Widget +horizontalLayoutWidget form uiState hl = + WHorizontalLayout <| widgetList form uiState hl.elements + + +verticalLayoutWidget : Form -> UiState -> UI.VerticalLayout -> Widget +verticalLayoutWidget form uiState hl = + WVerticalLayout <| widgetList form uiState hl.elements + + +groupWidget : Form -> UiState -> UI.Group -> Widget +groupWidget form uiState group = + WGroup + { label = group.label + , elements = widgetList form uiState group.elements + } + + +widgetList : Form -> UiState -> List UI.UiSchema -> List Widget +widgetList form uiState = + List.filterMap identity + << List.indexedMap + (\ix us -> + goWidget form (walkState ix us uiState) + ) + + +categorizationWidget : Form -> UiState -> UI.Categorization -> Widget +categorizationWidget form uiState categorization = + let + focusedCategoryIx = + Maybe.withDefault 0 <| Dict.get uiState.uiPath form.state.categoryFocus + + categoryButton ix cat = + if Rule.computeRule form.state.value cat.rule == Just Rule.Hidden then + Nothing + + else + Just + { label = cat.label + , focus = focusedCategoryIx == ix + , onClick = FocusCategory uiState.uiPath ix + } + + categoryUiState cat = + walkState focusedCategoryIx (UI.UiVerticalLayout { elements = cat.elements, rule = cat.rule }) uiState + in + WCategorization + { buttons = Maybe.values <| List.indexedMap categoryButton categorization.elements + , elements = + Maybe.unwrap + [] + (\cat -> widgetList form (categoryUiState cat) cat.elements) + (List.getAt focusedCategoryIx categorization.elements) + } + + +labelWidget : UI.Label -> Widget +labelWidget l = + WLabel l.text + + +controlWidget : UI.DefOptions -> UiState -> Schema -> SubSchema -> UI.Control -> FormState -> Maybe Widget +controlWidget defaultOptions uiState wholeSchema subSchema control form = + let + defOptions = + UI.applyDefaults defaultOptions control.options + + elementId = + inputElementId form.formId control.scope + + controlOptions = + let + disabled = + defOptions.readonly == True || uiState.disabled + + dispRequired = + isRequired wholeSchema control.scope && not defOptions.hideRequiredAsterisk + + validation = + if validateWidget control.scope form.validateWidgets then + case F.getErrorAt control.scope form.errors of + Just e -> + Invalid e + + Nothing -> + Valid + + else + NotValidated + + label = + fieldLabel control.label subSchema control.scope + + isCheckbox = + case controlBody of + Just (CCheckbox _) -> + True + + _ -> + False + + showDescription = + if isCheckbox || defOptions.showUnfocusedDescription || form.focus == Just control.scope then + subSchema.description + + else + Nothing + in + Maybe.map + (\lbl -> + { id = elementId + , label = lbl.label + , hideLabel = lbl.hideLabel + , disabled = disabled + , validation = validation + , required = dispRequired + , description = showDescription + , onFocus = Focus control.scope + , trim = defOptions.trim + } + ) + label + + pointedValue = + Maybe.withDefault (FieldValue.String "") <| + FieldValue.pointedFieldValue control.scope form.value + + controlBody : Maybe Control + controlBody = + case subSchema.type_ of + SingleType IntegerType -> + Just <| textLikeControl IntField pointedValue control.scope elementId defOptions subSchema + + SingleType NumberType -> + Just <| textLikeControl NumberField pointedValue control.scope elementId defOptions subSchema + + SingleType StringType -> + Just <| textLikeControl (StringField <| formatFromSchema subSchema.format) pointedValue control.scope elementId defOptions subSchema + + SingleType BooleanType -> + Just <| + CCheckbox + { value = FieldValue.asBool pointedValue + , onCheck = Input control.scope << FieldValue.Bool + } + + _ -> + Nothing + in + Maybe.map2 WControl controlOptions controlBody + + +textLikeControl : FieldType -> FieldValue -> Pointer -> String -> UI.DefOptions -> SubSchema -> Control +textLikeControl fieldType fieldValue pointer elementId defOptions subSchema = + if subSchema.enum /= Nothing then + if defOptions.format == Just UI.Radio then + CRadioGroup + { valueList = + Maybe.toList subSchema.enum + |> List.concat + |> List.map (Decode.decodeValue UI.decodeStringLike >> Result.withDefault "") + |> List.map + (\label -> + { id = elementId ++ "-" ++ label + , label = label + , checked = FieldValue.asString fieldValue == label + , onClick = Input pointer <| fromFieldInput fieldType label + } + ) + , vertical = defOptions.orientation == UI.Vertical + } + + else + CSelect + { valueList = + Maybe.toList subSchema.enum + |> List.concat + |> List.map (Decode.decodeValue UI.decodeStringLike >> Result.withDefault "") + |> List.append [ "" ] + |> List.map + (\label -> + { label = label + , selected = FieldValue.asString fieldValue == label + } + ) + , onChange = Input pointer << fromFieldInput fieldType + } + + else if defOptions.slider == True then + let + step = + Maybe.withDefault 1.0 subSchema.multipleOf + + minimum = + Maybe.withDefault 1.0 subSchema.minimum + + maximum = + Maybe.withDefault 10.0 subSchema.maximum + + minLimit = + case subSchema.exclusiveMinimum of + Just (Schema.BoolBoundary False) -> + minimum + + Just (Schema.BoolBoundary True) -> + minimum + step + + Just (Schema.NumberBoundary x) -> + x + step + + _ -> + minimum + + maxLimit = + case subSchema.exclusiveMaximum of + Just (Schema.BoolBoundary True) -> + maximum - step + + Just (Schema.NumberBoundary x) -> + x - step + + _ -> + maximum + in + CSlider + { value = FieldValue.asString fieldValue + , onInput = Input pointer << fromFieldInput fieldType + , min = String.fromFloat minLimit + , max = String.fromFloat maxLimit + , step = String.fromFloat step + } + + else if defOptions.multi && isStringField fieldType then + CTextArea + { value = FieldValue.asString fieldValue + , maxLength = + if defOptions.restrict then + subSchema.maxLength + + else + Nothing + , onInput = Input pointer << fromFieldInput fieldType + } + + else + CTextInput + { value = FieldValue.asString fieldValue + , onInput = Input pointer << fromFieldInput fieldType + , fieldType = fieldType + , maxLength = + if defOptions.restrict then + subSchema.maxLength + + else + Nothing + } + + +{-| Approximate whether a control is required to display asterix in the label +-} +isRequired : Schema -> Pointer -> Bool +isRequired wholeSchema pointer = + let + elementSchema = + UI.pointToSubSchema wholeSchema pointer + + isCheckboxRequired = + case elementSchema of + Just schema -> + schema.type_ == SingleType BooleanType && schema.const == Just (Encode.bool True) + + Nothing -> + False + + parentSchema = + UI.pointToSubSchema wholeSchema (List.take (List.length pointer - 2) pointer) + + isPropertyRequired = + case ( parentSchema, List.last pointer ) of + ( Just schema, Just prop ) -> + List.any ((==) prop) (Maybe.withDefault [] schema.required) + + _ -> + False + in + isCheckboxRequired || isPropertyRequired + + +fieldLabel : Maybe UI.ControlLabel -> SubSchema -> Pointer -> Maybe { label : String, hideLabel : Bool } +fieldLabel label schema scope = + let + fallbackLabel = + schema.title + |> Maybe.orElse (List.last scope |> Maybe.map UI.fieldNameToTitle) + in + Maybe.map + (\fallback -> + case label of + Just (UI.StringLabel s) -> + { label = s, hideLabel = False } + + Just (UI.BoolLabel False) -> + { label = fallback, hideLabel = True } + + Just (UI.BoolLabel True) -> + { label = fallback, hideLabel = False } + + Nothing -> + { label = fallback, hideLabel = False } + ) + fallbackLabel + + +inputElementId : String -> Pointer -> String +inputElementId formId pointer = + formId ++ "-" ++ Pointer.toString pointer ++ "-input" + + +fromFieldInput : FieldType -> String -> FieldValue +fromFieldInput fieldType = + case fieldType of + StringField _ -> + fromStringInput + + IntField -> + fromIntInput + + NumberField -> + fromFloatInput + + +formatFromSchema : Maybe String -> FieldFormat +formatFromSchema = + Maybe.withDefault Text + << Maybe.map + (\f -> + case f of + "email" -> + Email + + "date" -> + Date + + "time" -> + Time + + "date-time" -> + DateTime + + "phone" -> + Phone + + _ -> + Text + ) + + +isStringField : FieldType -> Bool +isStringField fieldType = + case fieldType of + StringField _ -> + True + + _ -> + False diff --git a/src/Form/Widget/View.elm b/src/Form/Widget/View.elm new file mode 100644 index 0000000..3808473 --- /dev/null +++ b/src/Form/Widget/View.elm @@ -0,0 +1,377 @@ +module Form.Widget.View exposing (errorString, viewWidget) + +import Form.Error exposing (ErrorValue(..)) +import Form.State exposing (Msg) +import Form.Widget exposing (..) +import Html exposing (Html, div) +import Html.Attributes as Attrs exposing (class) +import Html.Attributes.Extra as Attrs +import Html.Events as Events +import Html.Extra as Html +import Json.Decode as Decode +import Json.Encode as Encode +import Maybe.Extra as Maybe + + +viewWidget : Widget -> Html Msg +viewWidget widget = + case widget of + WHorizontalLayout widgets -> + div + [ class ("grid gap-3 grid-cols-" ++ String.fromInt (List.length widgets)) + ] + (List.map viewWidget widgets) + + WVerticalLayout widgets -> + div [] (List.map viewWidget widgets) + + WGroup group -> + div [ class "p-3 my-3 border border-gray-300" ] (div [ class "font-bold" ] [ Html.viewMaybe Html.text group.label ] :: List.map viewWidget group.elements) + + WCategorization categorization -> + let + menu = + div [ class "my-4 border-b" ] (List.map menuItem categorization.buttons) + + menuItem button = + Html.button + [ class "p-4 pb-2" + , Attrs.classList + [ ( "text-blue-500 border-b-2 border-blue-500", button.focus ) + ] + , Events.onClick button.onClick + ] + [ Html.text button.label ] + + body = + div [] (List.map viewWidget categorization.elements) + in + div [] [ menu, body ] + + WLabel label -> + div [ class "font-bold mt-4" ] [ Html.text label ] + + WControl options control -> + viewControl options control + + +viewControl : Options -> Control -> Html Msg +viewControl options control = + controlWrapper options <| + case control of + CTextInput textInput -> + viewTextInput options textInput + + CTextArea textArea -> + viewTextArea options textArea + + CSelect select -> + viewSelect options select + + CRadioGroup radioGroup -> + viewRadioGroup options radioGroup + + CCheckbox checkbox -> + viewCheckbox options checkbox + + CSlider sliderInput -> + viewSlider options sliderInput + + +controlWrapper : Options -> List (Html Msg) -> Html Msg +controlWrapper options = + div [ class "my-4", Attrs.classList [ ( "opacity-50", options.disabled ) ] ] + + +viewTextInput : Options -> TextInput -> List (Html Msg) +viewTextInput options textInput = + [ viewLabel options.label options.hideLabel options.required + , Html.input + [ Attrs.type_ <| inputType textInput.fieldType + , Attrs.id options.id + , Attrs.classList + [ ( "border-red-600", isInvalid options.validation ) + , ( "w-full", not options.trim ) + ] + , Attrs.value textInput.value + , Attrs.disabled options.disabled + , Events.onInput textInput.onInput + , Events.onFocus options.onFocus + , Maybe.unwrap Attrs.empty Attrs.maxlength textInput.maxLength + ] + [] + , viewDescription options.description + , viewErrorMessage options.validation + ] + + +viewTextArea : Options -> TextArea -> List (Html Msg) +viewTextArea options textArea = + [ viewLabel options.label options.hideLabel options.required + , Html.textarea + [ Attrs.id options.id + , Attrs.classList + [ ( "border-red-600", isInvalid options.validation ) + , ( "w-full", not options.trim ) + ] + , Attrs.value textArea.value + , Attrs.disabled options.disabled + , Events.onInput textArea.onInput + , Events.onFocus options.onFocus + , Attrs.attribute "rows" "4" + , Maybe.unwrap Attrs.empty Attrs.maxlength textArea.maxLength + ] + [] + , viewDescription options.description + , viewErrorMessage options.validation + ] + + +viewRadioGroup : Options -> RadioGroup -> List (Html Msg) +viewRadioGroup options radioGroup = + let + radio { id, label, checked, onClick } = + Html.label + [ Attrs.for id + , Attrs.classList + [ ( "mr-5 items-center", True ) + , ( "flex", radioGroup.vertical ) + ] + ] + [ Html.input + [ Attrs.type_ "radio" + , Attrs.id id + , Attrs.class "mr-3" + , Attrs.classList [ ( "border-red-600", isInvalid options.validation ) ] + , Attrs.checked checked + , Attrs.disabled options.disabled + , Events.onClick onClick + , Events.onFocus options.onFocus + ] + [] + , Html.span [ class "text-sm my-0.5" ] [ Html.text label ] + ] + in + [ viewLabel options.label options.hideLabel options.required + , div [] <| + List.map radio radioGroup.valueList + , viewDescription options.description + , viewErrorMessage options.validation + ] + + +viewSelect : Options -> Select -> List (Html Msg) +viewSelect options select = + let + buildOption { label, selected } = + Html.option [ Attrs.value label, Attrs.selected selected ] [ Html.text label ] + in + [ viewLabel options.label options.hideLabel options.required + , Html.select + [ Attrs.id options.id + , Attrs.classList + [ ( "border-red-600", isInvalid options.validation ) + , ( "w-full", not options.trim ) + ] + , Attrs.disabled options.disabled + , Events.on "change" (Events.targetValue |> Decode.map select.onChange) + , Events.onFocus options.onFocus + , Attrs.attribute "rows" "4" + ] + (List.map buildOption select.valueList) + , viewDescription options.description + , viewErrorMessage options.validation + ] + + +viewCheckbox : Options -> Checkbox -> List (Html Msg) +viewCheckbox options checkbox = + [ Html.label + [ Attrs.for options.id + , class "flex items-center space-x-4" + , Maybe.unwrap Attrs.empty Attrs.title options.description + ] + [ Html.input + [ Attrs.type_ "checkbox" + , Attrs.id options.id + , Attrs.classList [ ( "border-red-600", isInvalid options.validation ) ] + , Attrs.checked checkbox.value + , Attrs.disabled options.disabled + , Events.onCheck checkbox.onCheck + , Events.onFocus options.onFocus + ] + [] + , viewLabel options.label options.hideLabel options.required + ] + , viewErrorMessage options.validation + ] + + +viewSlider : Options -> Slider -> List (Html Msg) +viewSlider options sliderInput = + [ viewLabel options.label options.hideLabel options.required + , div [ Attrs.style "display" "flex", Attrs.class "text-sm" ] + [ Html.span [ Attrs.style "flex-grow" "1", Attrs.class "text-left" ] [ Html.text sliderInput.min ] + , Html.span [ Attrs.style "flex-grow" "1", Attrs.class "text-right" ] [ Html.text sliderInput.max ] + ] + , Html.input + [ Attrs.id options.id + , Attrs.classList + [ ( "border-red-600", isInvalid options.validation ) + , ( "w-full", not options.trim ) + , ( "w-52", options.trim ) + ] + , Attrs.value sliderInput.value + , Attrs.disabled options.disabled + , Events.onInput sliderInput.onInput + , Events.onFocus options.onFocus + , Attrs.attribute "rows" "4" + , Attrs.type_ "range" + , Attrs.attribute "min" sliderInput.min + , Attrs.attribute "max" sliderInput.max + , Attrs.attribute "step" sliderInput.step + ] + [] + , viewDescription options.description + , viewErrorMessage options.validation + ] + + +inputType : FieldType -> String +inputType fieldType = + case fieldType of + StringField format -> + case format of + Text -> + "text" + + Email -> + "email" + + Date -> + "date" + + Time -> + "time" + + DateTime -> + "datetime-local" + + Phone -> + "tel" + + NumberField -> + "number" + + IntField -> + "number" + + +viewLabel : String -> Bool -> Bool -> Html Msg +viewLabel label hideLabel required = + Html.viewIf (not hideLabel) <| + Html.span + [ class "block text-sm my-1" + ] + [ Html.text <| + label + ++ (if required then + " *" + + else + "" + ) + ] + + +viewDescription : Maybe String -> Html Msg +viewDescription description = + Html.viewMaybe (\d -> Html.div [ class "text-slate-500 text-sm" ] [ Html.text d ]) description + + +viewErrorMessage : Validation -> Html Msg +viewErrorMessage validation = + case validation of + Invalid e -> + Html.div [ class "text-red-600 text-sm" ] [ Html.text (errorString e) ] + + _ -> + Html.nothing + + +errorString : ErrorValue -> String +errorString error = + case error of + Empty -> + "is a required property" + + NotConst v -> + case Encode.encode 0 v of + "true" -> + "must be checked" + + "false" -> + "must be unchecked" + + s -> + "must be equal to " ++ s + + InvalidString -> + "not a valid string" + + InvalidFormat _ -> + "not the correct format" + + InvalidInt -> + "not a valid integer" + + InvalidFloat -> + "not a valid number" + + InvalidBool -> + "not a valid option" + + InvalidNull -> + "not a null" + + LessIntThan n -> + "can not be smaller than " ++ String.fromInt n + + LessEqualIntThan n -> + "can not be smaller or equal than " ++ String.fromInt n + + GreaterIntThan n -> + "can not be greater than " ++ String.fromInt n + + GreaterEqualIntThan n -> + "can not be greater or equal than " ++ String.fromInt n + + LessFloatThan n -> + "can not be smaller than " ++ String.fromFloat n + + LessEqualFloatThan n -> + "can not be smaller or equal than " ++ String.fromFloat n + + GreaterFloatThan n -> + "can not be greater than " ++ String.fromFloat n + + GreaterEqualFloatThan n -> + "can not be greater or equal than " ++ String.fromFloat n + + ShorterStringThan n -> + "must NOT have fewer than " ++ String.fromInt n ++ " characters" + + LongerStringThan n -> + "must NOT have more than " ++ String.fromInt n ++ " characters" + + NotMultipleOfInt n -> + "must be a multiple of " ++ String.fromInt n ++ "." + + NotMultipleOfFloat n -> + "must be a multiple of " ++ String.fromFloat n ++ "." + + NotIncludedIn _ -> + "is not a valid selection from the list." + + Unimplemented s -> + "unimplemented: " ++ s diff --git a/src/UiSchema.elm b/src/UiSchema.elm index 9d33fba..30f1636 100644 --- a/src/UiSchema.elm +++ b/src/UiSchema.elm @@ -1,16 +1,16 @@ -module UiSchema exposing (UiSchema, fromString, decode, generate) +module UiSchema exposing (UiSchema, DefOptions, fromString, decode, generate, defaultOptions) {-| UI Schema definition and deserialization. Documentation can be found here: -@docs UiSchema, fromString, decode, generate +@docs UiSchema, DefOptions, fromString, decode, generate, defaultOptions -} import Json.Decode as Decode import Json.Schema.Definitions exposing (Schema) -import UiSchema.Internal exposing (decodeUiSchema, generateUiSchema) +import UiSchema.Internal exposing (DefOptions, decodeUiSchema, generateUiSchema) {-| UI Schema definition @@ -19,6 +19,12 @@ type alias UiSchema = UiSchema.Internal.UiSchema +{-| Options for the UI Schema +-} +type alias DefOptions = + UiSchema.Internal.DefOptions + + {-| UiSchema Decoder -} decode : Decode.Decoder UiSchema @@ -41,3 +47,10 @@ The generated UI schema contains vertical layout with controls for all primitive generate : Schema -> UiSchema generate = generateUiSchema + + +{-| Default options for the UI Schema +-} +defaultOptions : DefOptions +defaultOptions = + UiSchema.Internal.defaultOptions diff --git a/src/UiSchema/Internal.elm b/src/UiSchema/Internal.elm index 00bd6ba..56bd5e4 100644 --- a/src/UiSchema/Internal.elm +++ b/src/UiSchema/Internal.elm @@ -20,19 +20,21 @@ module UiSchema.Internal exposing , applyDefaults , decodeStringLike , decodeUiSchema + , defaultOptions , defaultValue , fieldNameToTitle , generateUiSchema , getRule - , pointToSchema + , pointToSubSchema ) import Json.Decode as Decode exposing (Decoder, Value) import Json.Decode.Pipeline as Decode import Json.Encode as Encode import Json.Pointer as Pointer exposing (Pointer) -import Json.Schema.Definitions as Schema exposing (Schema) +import Json.Schema.Definitions as Schema exposing (Schema, SubSchema) import Json.Util as Util +import Maybe.Extra as Maybe import String.Case @@ -153,47 +155,48 @@ type alias DefOptions = } -emptyOptions : Options -emptyOptions = +defaultOptions : DefOptions +defaultOptions = { format = Nothing - , orientation = Nothing - , showSortButtons = Nothing - , detail = Nothing + , orientation = Horizontal + , showSortButtons = False + , detail = DetailDefault , elementLabelProp = Nothing - , readonly = Nothing - , multi = Nothing - , slider = Nothing - , trim = Nothing - , restrict = Nothing - , showUnfocusedDescription = Nothing - , hideRequiredAsterisk = Nothing - , toggle = Nothing + , readonly = False + , multi = False + , slider = False + , trim = False + , restrict = False + , showUnfocusedDescription = False + , hideRequiredAsterisk = False + , toggle = False , variant = Nothing - , showNavButtons = Nothing + , showNavButtons = False } -applyDefaults : Maybe Options -> DefOptions -applyDefaults options = - Maybe.withDefault emptyOptions options - |> (\o -> - { format = o.format - , orientation = Maybe.withDefault Horizontal o.orientation - , showSortButtons = Maybe.withDefault False o.showSortButtons - , detail = Maybe.withDefault DetailDefault o.detail - , elementLabelProp = o.elementLabelProp - , readonly = Maybe.withDefault False o.readonly - , multi = Maybe.withDefault False o.multi - , slider = Maybe.withDefault False o.slider - , trim = Maybe.withDefault False o.trim - , restrict = Maybe.withDefault False o.restrict - , showUnfocusedDescription = Maybe.withDefault False o.showUnfocusedDescription - , hideRequiredAsterisk = Maybe.withDefault False o.hideRequiredAsterisk - , toggle = Maybe.withDefault False o.toggle - , variant = Nothing - , showNavButtons = Maybe.withDefault False o.showNavButtons - } - ) +applyDefaults : DefOptions -> Maybe Options -> DefOptions +applyDefaults d mo = + Maybe.unwrap d + (\o -> + { format = Maybe.or o.format d.format + , orientation = Maybe.withDefault d.orientation o.orientation + , showSortButtons = Maybe.withDefault d.showSortButtons o.showSortButtons + , detail = Maybe.withDefault d.detail o.detail + , elementLabelProp = Maybe.or o.elementLabelProp d.elementLabelProp + , readonly = Maybe.withDefault d.readonly o.readonly + , multi = Maybe.withDefault d.multi o.multi + , slider = Maybe.withDefault d.slider o.slider + , trim = Maybe.withDefault d.trim o.trim + , restrict = Maybe.withDefault d.restrict o.restrict + , showUnfocusedDescription = Maybe.withDefault d.showUnfocusedDescription o.showUnfocusedDescription + , hideRequiredAsterisk = Maybe.withDefault d.hideRequiredAsterisk o.hideRequiredAsterisk + , toggle = Maybe.withDefault d.toggle o.toggle + , variant = Maybe.or o.variant d.variant + , showNavButtons = Maybe.withDefault d.showNavButtons o.showNavButtons + } + ) + mo type Format @@ -510,12 +513,28 @@ pointToSchema schema pointer = Nothing Just (Schema.Schemata props) -> - Maybe.andThen (\( _, p ) -> pointToSchema p xs) <| List.head <| List.filter (\( n, _ ) -> n == x) props + Maybe.andThen (\( _, p ) -> pointToSchema p xs) <| + List.head <| + List.filter (\( n, _ ) -> n == x) props _ -> Nothing +pointToSubSchema : Schema -> Pointer -> Maybe SubSchema +pointToSubSchema schema = + pointToSchema schema + >> Maybe.andThen + (\s -> + case s of + Schema.ObjectSchema subSchema -> + Just subSchema + + _ -> + Nothing + ) + + getRule : UiSchema -> Maybe Rule getRule uiSchema = case uiSchema of diff --git a/src/UiSchema/Rule.elm b/src/UiSchema/Rule.elm index b537da7..fdd05d6 100644 --- a/src/UiSchema/Rule.elm +++ b/src/UiSchema/Rule.elm @@ -1,6 +1,6 @@ module UiSchema.Rule exposing (AppliedEffect(..), computeRule) -import Form.Validation exposing (validation) +import Form.Validation exposing (validate) import Json.Decode exposing (Value) import Json.Pointer as Pointer import UiSchema.Internal as UI exposing (Effect(..)) @@ -21,7 +21,7 @@ computeRule formValue mRule = False Just v -> - Validation.isOk <| validation rule.condition.schema v + Validation.isOk <| validate rule.condition.schema v go rule = case ( rule.effect, condition rule ) of diff --git a/src/Validation.elm b/src/Validation.elm index 3d5e708..9dfb374 100644 --- a/src/Validation.elm +++ b/src/Validation.elm @@ -4,11 +4,13 @@ module Validation exposing , error , fail , isOk + , map , mapErrorPointers , oneOf , succeed , unless , validateAll + , voidRight , whenJust ) @@ -67,6 +69,8 @@ oneOf validations v = List.foldl f (Err (error Error.Empty)) validations +{-| Run a list of validations, discard their results +-} validateAll : List (a -> Validation b) -> a -> Validation a validateAll l a = let @@ -95,6 +99,16 @@ andMap aValidation partialValidation = Err (List.append (errList partialResult) (errList aResult)) +map : (a -> b) -> Validation a -> Validation b +map f v = + andMap v (Ok f) + + +voidRight : a -> Validation b -> Validation a +voidRight a = + map (always a) + + errList : Validation a -> Errors errList res = case res of