Add custom validation class (#184)

Author: Madeline Trotter

bower.json

@@ -45,7 +45,8 @@
     "purescript-heterogeneous": ">=0.3.0 <0.5.0",
     "purescript-free": "^5.1.0",
     "purescript-colors": "^5.0.0",
-    "purescript-web-uievents": "^2.0.0"
+    "purescript-web-uievents": "^2.0.0",
+    "purescript-foreign-generic": "^10.0.0"
   },
   "devDependencies": {
     "purescript-debug": "^4.0.0",

docs/Examples/Form.example.purs

@@ -11,6 +11,7 @@ import Data.Foldable (foldMap)
 import Data.Int as Int
 import Data.Lens (iso)
 import Data.Lens.Iso (mapping)
+import Data.Lens.Iso.Newtype (_Newtype)
 import Data.Lens.Record (prop)
 import Data.Maybe (Maybe(..), isNothing, maybe)
 import Data.Monoid as Monoid
@@ -23,15 +24,15 @@ import Effect.Aff (Milliseconds(..), delay, error, throwError)
 import Effect.Class (liftEffect)
 import Effect.Random (randomRange)
 import Effect.Unsafe (unsafePerformEffect)
+import Heterogeneous.Mapping as H
 import Lumi.Components.Button as Button
 import Lumi.Components.Color (colors)
 import Lumi.Components.Column (column, column_)
 import Lumi.Components.Example (example)
-import Lumi.Components.Form (FormBuilder, Validated)
+import Lumi.Components.Form (class CustomModifyValidated, FormBuilder, ModifyValidatedProxy, Validated)
 import Lumi.Components.Form as F
 import Lumi.Components.Form.Defaults (formDefaults)
 import Lumi.Components.Form.Table as FT
-import Lumi.Components.Form.Validation (ValidatedNewtype, _ValidatedNewtype)
 import Lumi.Components.Input as Input
 import Lumi.Components.LabeledField (RequiredField(..))
 import Lumi.Components.Modal (dialog)
@@ -201,7 +202,7 @@ type User =
   , descriptiveCheckbox :: Boolean
   , height :: Validated String
   , addresses :: Validated (Array Address)
-  , pets :: Validated (Array (ValidatedNewtype Pet))
+  , pets :: Validated (Array (ModifyValidatedProxy Pet))
   -- ^ validation helpers like `setModified` need a little assistance getting
   --     into Newtypes like `Pet`, hence this `ValidatedNewtype` wrapper
   , leastFavoriteColors :: Validated (Array String)
@@ -234,6 +235,9 @@ newtype Pet = Pet
 
 derive instance ntPet :: Newtype Pet _
 
+instance cmvPet :: CustomModifyValidated Pet where
+  customModifyValidated f (Pet a) = Pet (H.mapping f a)
+
 type ValidatedPet =
   { name :: NonEmptyString
   , animal :: String
@@ -343,7 +347,7 @@ userForm = ado
 
   F.section "Pets"
   pets <-
-    F.focus (prop (SProxy :: SProxy "pets") <<< mapping (mapping _ValidatedNewtype))
+    F.focus (prop (SProxy :: SProxy "pets") <<< mapping (mapping (_Newtype <<< _Newtype)))
     $ F.warn (\pets ->
         Monoid.guard (Array.null pets) (pure "You should adopt a pet.")
       )

src/Lumi/Components/Form.purs

@@ -83,7 +83,7 @@ import Lumi.Components.FetchCache as FetchCache
 import Lumi.Components.Form.Defaults (formDefaults) as Defaults
 import Lumi.Components.Form.Internal (Forest, FormBuilder'(..), FormBuilder, SeqFormBuilder, Tree(..), formBuilder, formBuilder_, invalidate, pruneTree, sequential)
 import Lumi.Components.Form.Internal (Forest, FormBuilder', FormBuilder, SeqFormBuilder', SeqFormBuilder, Tree(..), formBuilder, formBuilder_, invalidate, listen, parallel, revalidate, sequential) as Internal
-import Lumi.Components.Form.Validation (ModifyValidated(..), Validated(..), ValidatedNewtype(..), Validator, _Validated, _ValidatedNewtype, fromValidated, mustBe, mustEqual, nonEmpty, nonEmptyArray, nonNull, nonEmpty', nonEmptyArray', nonNull', optional, setFresh, setModified, validDate, validInt, validNumber, validDate', validInt', validNumber', validated, warn) as Validation
+import Lumi.Components.Form.Validation (ModifyValidated(..), Validated(..), Validator, ModifyValidatedProxy(..), class CustomModifyValidated, customModifyValidated, _Validated, fromValidated, mustBe, mustEqual, nonEmpty, nonEmptyArray, nonNull, nonEmpty', nonEmptyArray', nonNull', optional, setFresh, setModified, validDate, validInt, validNumber, validDate', validInt', validNumber', validated, warn) as Validation
 import Lumi.Components.Input (alignToInput)
 import Lumi.Components.Input as Input
 import Lumi.Components.LabeledField (RequiredField(..), labeledField, labeledFieldValidationErrorStyles, labeledFieldValidationWarningStyles)

src/Lumi/Components/Form/Validation.purs

@@ -10,7 +10,7 @@ module Lumi.Components.Form.Validation
   , _Validated, _Fresh, _Modified
   , setFresh, setModified
   , ModifyValidated(..)
-  , ValidatedNewtype(..), _ValidatedNewtype
+  , ModifyValidatedProxy(..), class CustomModifyValidated, customModifyValidated
   , class CanValidate, fresh, modified, fromValidated
   , validated
   , warn
@@ -26,8 +26,10 @@ import Data.Either (Either(..), either, hush, note)
 import Data.Enum (toEnum)
 import Data.Eq (class Eq1)
 import Data.Foldable (foldMap)
+import Data.Function (on)
+import Data.Generic.Rep (class Generic, from, to)
 import Data.Int as Int
-import Data.Lens (Lens, Prism', Iso', lens, over, prism', review, view)
+import Data.Lens (Lens, Prism', lens, over, prism', review, view)
 import Data.Lens.Iso.Newtype (_Newtype)
 import Data.Maybe (Maybe(..))
 import Data.Monoid (guard)
@@ -40,6 +42,7 @@ import Data.String.NonEmpty (NonEmptyString)
 import Data.String.NonEmpty (fromString) as NES
 import Data.String.Pattern (Pattern(..))
 import Data.Traversable (traverse)
+import Foreign.Generic (class Decode, class Encode, decode, encode)
 import Heterogeneous.Mapping (class MapRecordWithIndex, class Mapping, ConstMapping, hmap, mapping)
 import Lumi.Components.Column (column)
 import Lumi.Components.Form.Internal (Forest, FormBuilder, FormBuilder'(..), Tree(..))
@@ -160,6 +163,18 @@ instance applyValidated :: Apply Validated where
 instance applicativeValidated :: Applicative Validated where
   pure = Fresh
 
+instance genericValidated :: Generic value rep => Generic (Validated value) rep where
+  to = Fresh <<< to
+  from (Fresh value) = from value
+  from (Modified value) = from value
+
+instance decodeValidated :: Decode value => Decode (Validated value) where
+  decode value = Fresh <$> decode value
+
+instance encodeValidated :: Encode value => Encode (Validated value) where
+  encode (Fresh value) = encode value
+  encode (Modified value) = encode value
+
 -- | Lens for viewing and modifying `Validated` values.
 _Validated :: forall a b. Lens (Validated a) (Validated b) a b
 _Validated = flip lens ($>) $
@@ -203,12 +218,31 @@ setModified = mapping (ModifyValidated (Modified <<< view _Validated))
 -- | records containing `Validated` values.
 newtype ModifyValidated = ModifyValidated (Validated ~> Validated)
 
-newtype ValidatedNewtype a = ValidatedNewtype a
+newtype ModifyValidatedProxy a = ModifyValidatedProxy a
+
+unModifyValidatedProxy :: forall value. ModifyValidatedProxy value -> value
+unModifyValidatedProxy (ModifyValidatedProxy value) = value
+
+derive instance ntMVP :: Newtype (ModifyValidatedProxy a) _
 
-derive instance ntMVP :: Newtype (ValidatedNewtype a) _
+instance eqValidatedNewtype :: Eq value => Eq (ModifyValidatedProxy value) where
+  eq = eq `on` unModifyValidatedProxy
 
-_ValidatedNewtype :: forall s a. Newtype s a => Iso' (ValidatedNewtype s) a
-_ValidatedNewtype = _Newtype <<< _Newtype
+instance ordValidatedNewtype :: Ord value => Ord (ModifyValidatedProxy value) where
+  compare = compare `on` unModifyValidatedProxy
+
+instance genericValidatedNewtype :: Generic value rep => Generic (ModifyValidatedProxy value) rep where
+  to = ModifyValidatedProxy <<< to
+  from = from <<< unModifyValidatedProxy
+
+instance decodeValidatedNewtype :: Decode value => Decode (ModifyValidatedProxy value) where
+  decode value = ModifyValidatedProxy <$> decode value
+
+instance encodeValidatedNewtype :: Encode value => Encode (ModifyValidatedProxy value) where
+  encode (ModifyValidatedProxy value) = encode value
+
+class CustomModifyValidated a where
+  customModifyValidated :: ModifyValidated -> a -> a
 
 instance modifyValidated :: Mapping ModifyValidated a a => Mapping ModifyValidated (Validated a) (Validated a) where
   mapping m@(ModifyValidated f) = over _Validated (mapping m) <<< f
@@ -219,8 +253,10 @@ else instance modifyValidatedRecord ::
   mapping d = hmap d
 else instance modifyValidatedArray :: Mapping ModifyValidated a a => Mapping ModifyValidated (Array a) (Array a) where
   mapping d = map (mapping d)
-else instance modifyValidatedNewtype :: (Newtype a b, Mapping ModifyValidated b b) => Mapping ModifyValidated (ValidatedNewtype a) (ValidatedNewtype a) where
-  mapping d = over (_Newtype <<< _Newtype) (mapping d)
+else instance modifyValidatedMaybe :: Mapping ModifyValidated a a => Mapping ModifyValidated (Maybe a) (Maybe a) where
+  mapping d = map (mapping d)
+else instance modifyValidatedProxy :: (CustomModifyValidated a, Mapping ModifyValidated a a) => Mapping ModifyValidated (ModifyValidatedProxy a) (ModifyValidatedProxy a) where
+  mapping f = over _Newtype (customModifyValidated f)
 else instance modifyValidatedIdentity :: Mapping ModifyValidated a a where
   mapping _ = identity