01-validation.purs

module Main where

import Prim

import Control.Alt ((<|>))
import Control.Apply ((<*>))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Functor ((<$>), map)
import Data.String.CodePoints (contains)
import Data.String.Pattern (Pattern(..))
import Data.String.Utils (lines)
import Data.Validation.Semiring (V, toEither, invalid)
import Effect (Effect)
import Effect.Console (log)
import Prelude (class Semiring, class Show, Unit, pure, show, ($), (<>), append, (<<<))

newtype Person = Person {
  first :: String,
  last :: String,
  contact :: String
}
derive newtype instance showPerson :: Show Person

-- type Errors = Array String


data Quantifier = AllOf | AnyOf
data Errors = None | Error String | Errors Quantifier (Array Errors)

instance showErrors :: Show Errors where
  show (Error s) = s
  show None = ""
  show (Errors x list) = "needs " <> quantifier x <> " of the following:\n" <> report
    where report = intercalate "\n" $ ((intercalate "\n" <<< map (append "  ") <<< lines <<< show) <$> list)
          quantifier AllOf = "all"
          quantifier AnyOf = "any"

instance semiringArrayString :: Semiring Errors where
  mul (None) a = a
  mul a (None) = a
  mul (Errors AllOf l1) (Errors AllOf l2) = Errors AllOf (l1 <> l2)
  mul (Errors AllOf l1) a = Errors AllOf (l1 <> [a])
  mul a (Errors AllOf l1) = Errors AllOf ([a] <> l1)
  mul a b = Errors AllOf [ a, b ]
  add (None) a = a
  add a (None) = a
  add (Errors AnyOf a) (Errors AnyOf b) = Errors AnyOf (a <> b)
  add (Errors AnyOf a) b = Errors AnyOf (a <> [b])
  add a (Errors AnyOf b) = Errors AnyOf ([a] <> b)
  add a b = Errors AnyOf [a, b]
  one = None
  zero = None


withLabel :: forall t. String -> V Errors t -> V Errors t
withLabel label v =
  case (toEither v) of
    Left e -> invalid $ withLabel' label e
    other -> v

withLabel' :: String -> Errors -> Errors
withLabel' label (Error e) = Error $ label <> e
withLabel' label (Errors q e) = Errors q $ withLabel' label <$> e
withLabel' label None = None


validateName :: String -> V Errors String
validateName "" = invalid $ Error "needs to be non-empty"
validateName name = pure name

validateEmail :: String -> V Errors String
validateEmail mail =
  if contains (Pattern "@") mail then pure mail else invalid $ Error "needs to contain @"

validatePhone :: String -> V Errors String
validatePhone phone =
  if contains (Pattern "+") phone then pure phone else invalid $ Error "needs to contain +"

personify :: String -> String -> String -> Person
personify first last contact = Person { first, last, contact }

validate :: Person -> V Errors Person
validate (Person p) = personify
  <$> withLabel "first name " (validateName p.first)
  <*> withLabel "last name " (validateName p.last)
  <*> withLabel "contact " (validateEmail p.contact <|> validatePhone p.contact)

main :: Effect Unit
main = do
  log $ show $ validate $ Person {first: "", last: "", contact:"a"}

02-output.txt

38590 % pulp run
* Building project in /home/spion/Projects/tests/purescript-validations
* Build successful.
invalid (needs all of the following:
  first name needs to be non-empty
  last name needs to be non-empty
  needs any of the following:
    contact needs to contain @
    contact needs to contain +)