validations 0.1.0.0 → 0.1.0.1

raw patch · 9 files changed

+164/−1 lines, 9 files

Files

• src/Validations/Adapters.hs +5/−0
• src/Validations/Adapters/Digestive.hs +30/−0
• src/Validations/Internal.hs +5/−0
• src/Validations/Internal/Lens.hs +22/−0
• src/Validations/Types.hs +5/−0
• src/Validations/Types/Checker.hs +8/−0
• src/Validations/Validation.hs +48/−0
• src/Validations/Validator.hs +32/−0
• validations.cabal +9/−1

@@ -0,0 +1,5 @@+module Validations.Adapters+  ( module Validations.Adapters.Digestive+  ) where++import Validations.Adapters.Digestive

@@ -0,0 +1,30 @@+module Validations.Adapters.Digestive+  ( validateView+  , validateView'+  , testEnv+  ) +   where++import Data.Monoid(Monoid, (<>), mempty)+import Text.Digestive.View(View,absolutePath, viewErrors)+import Validations.Validation(Validation, runValidation)+import Data.Text(Text)+import Text.Digestive.Form.Encoding(FormEncType)+import Text.Digestive.Types(Env, FormInput(TextInput), fromPath)++validateView :: (Monad m) => (s -> Validation [(Text, e)] m t u) -> t -> (View e, Maybe s) -> m (View e, Maybe u)+validateView validation t (v,ms) = case ms of+  Nothing -> return $ (v, Nothing)+  Just s  -> do+    (t',es) <- (runValidation (validation s)) t+    es' <- return $  (map (\y -> (absolutePath (fst y) v, snd y)) es) <> (viewErrors v)+    case es of+      [] -> return $ (v, Just t')+      _  -> return $ (v {viewErrors = (viewErrors v) <> es'}, Nothing)++validateView' :: (Monad m, Monoid t) => (s -> Validation [(Text, e)] m t u) -> (View e, Maybe s) -> m (View e, Maybe u)+validateView' validation (v,ms) = validateView validation mempty (v,ms)++testEnv :: Monad m => [(Text, Text)] -> FormEncType -> m (Env m)+testEnv input _formEncType = return $ \key -> return $ map (TextInput . snd) $+    filter ((== fromPath key) . fst) input

@@ -0,0 +1,5 @@+module Validations.Internal+  ( module Validations.Internal.Lens+  ) where++import Validations.Internal.Lens

@@ -0,0 +1,22 @@+{-# LANGUAGE Rank2Types #-}++module Validations.Internal.Lens+  ( getter+  , setter+  , lens+  , Lens+  ) where++import Control.Monad.Identity(Identity(Identity), runIdentity)+import Control.Applicative(Const(Const), getConst, (<$>))++type Lens a s = (Functor f) => (a -> f a) -> s -> f s++getter :: (forall f. (Functor f) => (a -> f a) -> s -> f s) -> s -> a+getter lns x = getConst $ lns (\y -> Const y) x++setter :: (forall f. (Functor f) => (a -> f a) -> s -> f s) -> s -> a -> s+setter lns x y = runIdentity $ lns (\_ -> Identity y) x++lens :: (Functor f) => (s -> a) -> (s -> a -> s) -> (a -> f a) -> s -> f s +lens get set lift input = set input <$> (lift . get) input

@@ -0,0 +1,5 @@+module Validations.Types+  ( module Validations.Types.Checker+  ) where++import Validations.Types.Checker

@@ -0,0 +1,8 @@+module Validations.Types.Checker+    ( Checker+    , MonadicChecker+    )+    where++type Checker error a b = a -> Either error b+type MonadicChecker error monad a b = a -> monad (Either error b)

@@ -0,0 +1,48 @@+{-# LANGUAGE RankNTypes        #-}++module Validations.Validation+  ( Validation(..)+  , validation+  , validation_+  , composeValidation+  , composeValidation'+  ) +    where++import Prelude hiding ((.))+import Validations.Internal.Lens(Lens, setter)+import Data.Monoid(Monoid, (<>), mempty)+import Control.Category(Category(..))+import Validations.Validator(Validator(..))++newtype Validation errors monad state newState = Validation { runValidation :: state -> monad (newState, errors) } + +instance (Monad m, Monoid e) => Category (Validation e m) where+  id = Validation (\s -> return (s,mempty))+  x . y = composeValidation y x +++composeValidation' :: (Monad m) => (e -> f -> g) -> Validation e m s t -> Validation f m t u -> Validation g m s u+composeValidation' fn (Validation v1) (Validation v2) = +  Validation $ \s      -> v1 s >>=+               \(t,e)  -> v2 t >>=+               \(u,f) -> return (u, fn e f)++composeValidation :: (Monad m, Monoid e) => Validation e m s t -> Validation e m t u -> Validation e m s u+composeValidation = composeValidation' (<>)++validation :: (Monad m) => Lens b s -> a -> Validator ek ev m a b -> Validation [(ek,ev)] m s s+validation lens a (Validator v) =+  Validation $ \s -> v a >>= +  \r -> case r of+    Left e  -> return (s, [e])+    Right b -> return (setter lens s b, [])++-- | Same as "validation", but throws away validator result. This is useful+--   for the side effects from a monadic validator.+validation_ :: (Monad m) =>  a -> Validator ek ev m a b -> Validation [(ek,ev)] m s s+validation_ a (Validator v) =+  Validation $ \s -> v a >>= +  \r -> case r of+    Left e  -> return (s, [e])+    Right _ -> return (s, [])

@@ -0,0 +1,32 @@+module Validations.Validator+  ( attach+  , attachM+  , Validator(..)+  , composeValidator+  ) +    where++import Validations.Types.Checker(Checker, MonadicChecker)+import Control.Category(Category(..))++attach :: (Monad m) => Checker ev a b -> ek -> Validator ek ev m a b+attach validator fieldName = Validator $ \x -> case (validator x) of+  Right x' -> return $ Right x'+  Left  e   -> return $ Left (fieldName, e)++attachM :: (Monad m) => MonadicChecker ev m a b -> ek -> Validator ek ev m a b+attachM validator fieldName = Validator $ \x -> validator x >>= \y -> case y of+  Right y' -> return $ Right y'+  Left  e   -> return $ Left (fieldName, e)++newtype Validator errorKey errorValue monad a b  = Validator { runValidator :: a -> monad (Either (errorKey, errorValue) b) }++instance (Monad m) => Category (Validator ek ev m) where+  id = Validator (\x -> return (Right x))+  y . x = composeValidator x y+++composeValidator :: (Monad m) => Validator ek ev m a b -> Validator ek ev m b c -> Validator ek ev m a c+composeValidator (Validator f) (Validator g) = Validator $ (\a -> f a >>= \rb -> case rb of+  Right b     -> g b+  Left   (fn,e) -> return (Left (fn, e)))

@@ -2,7 +2,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:                validations-version:             0.1.0.0+version:             0.1.0.1 synopsis:            A nice way to define field validations in Haskell. description:         See <https://github.com/mavenraven/validations> for description and tutorial.                      Code used in the tutorial can be found in src\/Validations\/Tutorial.lhs.@@ -20,6 +20,14 @@ Library   exposed-modules:            Validations+      Validations.Adapters+      Validations.Adapters.Digestive+      Validations.Internal+      Validations.Internal.Lens+      Validations.Types+      Validations.Types.Checker+      Validations.Validation+      Validations.Validator       Validations.Tutorial   -- other-modules:          -- other-extensions: