validationt (empty) → 0.1.0.0

raw patch · 5 files changed

+218/−0 lines, 5 filesdep +aesondep +basedep +lenssetup-changed

Dependencies added: aeson, base, lens, transformers

Files

ChangeLog.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
src/Control/Monad/Validation.hs +153/−0
validationt.cabal +28/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for validationt++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2017, Denis Redozubov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Denis Redozubov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Control/Monad/Validation.hs view

@@ -0,0 +1,153 @@++module Common.Validation where++import Control.Lens hiding ((.=))+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.State.Strict+import Control.Monad.Trans.Lift.Local+import Data.Aeson+import Data.Foldable as F+import Data.List as L+import Data.Map.Strict as M+import Data.Monoid+import Data.Text as T+import Data.Vector as V+import Test.QuickCheck++-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed+-- through ExceptT to single value using Monoid+--  FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask+newtype ValidationT e m a = ValidationT+  { unValidationT :: ExceptT e (StateT e m) a+  } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch+             , MonadBase b )++instance MonadTrans (ValidationT e) where+  lift = ValidationT . lift . lift++instance LiftLocal (ValidationT e) where+  liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT++-- | Map with 'Monoid' instance which 'mappend' its values+newtype MonoidMap k v = MonoidMap (Map k v)+  deriving (Eq, Ord, Show, Arbitrary)++makePrisms ''MonoidMap++type instance IxValue (MonoidMap k v) = v+type instance Index (MonoidMap k v) = k+instance (Ord k) => Ixed (MonoidMap k v) where+  ix key = _MonoidMap . ix key+instance (Ord k) => At (MonoidMap k v) where+  at key = _MonoidMap . at key++instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where+  mempty = MonoidMap M.empty+  mappend (MonoidMap a) (MonoidMap b) =+    MonoidMap $ M.unionWith (<>) a b++instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where+  toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m+    where+      toObj (k, v) = object+        [ "id" .= k+        , "value" .= v ]++instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where+  parseJSON v = withArray "MonoidMap" go v+    where+      go arr = do+        keyvals <- traverse fromObj arr+        return $ MonoidMap $ M.fromList $ V.toList keyvals+      fromObj objV = flip (withObject "element of MonoidMap") objV $ \obj -> do+        key <- obj .: "id"+        val <- obj .: "value"+        return (key, val)++-- | Convenient for 'vZoom' as first artument. Will prevent generation+-- of map with 'mempty' values+mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v+mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k++-- | Set given value to 'mempty'+setMempty :: (Monoid s) => ASetter' s a -> a -> s+setMempty setter a = set setter a mempty++memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b+memptyWrap b f a+  | a == mempty = b+  | otherwise = f a++-- | If given container is not 'mempty', then use given function to+-- append all its elements and return 'Just' result+neConcat+  :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))+  => (a -> a -> a)+  -> f a+  -> Maybe a+neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)++textErrors :: [Text] -> Maybe Text+textErrors = neConcat (\a b -> a <> ", " <> b)++-- | Returns `mempty` instead of error if no warnings was occured. So, your+-- error should have `Eq` instance to detect that any error was occured. Returns+-- Nothing for second element of tuple if compuration was interruped by 'vError'+runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)+runValidationT (ValidationT m) = do+  (res, warnings) <- runStateT (runExceptT m) mempty+  return $ case res of+    Left err -> (err <> warnings, Nothing)+    Right a  -> (warnings, Just a)++runValidationTEither+  :: (Monoid e, Eq e, Monad m)+  => ValidationT e m a+  -> m (Either e a)+runValidationTEither action = do+  (err, res) <- runValidationT action+  return $ case res of+    Just a | err == mempty -> Right a+    _                      -> Left err++handleValidationT+  :: (Monoid e, Monad m, Eq e)+  => (e -> m a)+  -> ValidationT e m a+  -> m a+handleValidationT handler action = do+  runValidationTEither action >>= either handler return++-- | Stops further execution of validation+vError :: (Monad m) => e -> ValidationT e m a+vError e = ValidationT $ throwError e++-- | Does not stop further execution, append warning to+vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()+vWarning e = ValidationT $ modify' (<> e)++vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x+vErrorL l a = vError $ setMempty l a++vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()+vWarningL l a = vWarning $ setMempty l a++vZoom+  :: (Monad m, Monoid a, Monoid b)+  => (a -> b)+  -> ValidationT a m x+  -> ValidationT b m x+vZoom up action = do+  (err, res) <- lift $ runValidationT action+  case res of+    Nothing -> vError $ up err+    Just a  -> vWarning (up err) *> return a++vZoomL+  :: (Monad m, Monoid a, Monoid b)+  => ASetter' b a+  -> ValidationT a m x+  -> ValidationT b m x+vZoomL l action = vZoom (setMempty l) action

+ validationt.cabal view

@@ -0,0 +1,28 @@+-- Initial validationt.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                validationt+version:             0.1.0.0+synopsis:            Straightforward validation monad. Convenient solution for validating web forms and APIs.+-- description:+homepage:            typeable.io+license:             BSD3+license-file:        LICENSE+author:              Typeable.io contributors+maintainer:          makeit@typeable.io+-- copyright:+category:            Control+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  exposed-modules:    Control.Monad.Validation+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.8 && < 5+                     , aeson >= 1.0+                     , transformers+                     , lens+  hs-source-dirs:      src+  default-language:    Haskell2010