From 62f5774a7b5515ce1f9e30c1c349217f4ef08f33 Mon Sep 17 00:00:00 2001
From: iko <ilyakooo0@gmail.com>
Date: Mon, 20 Jan 2020 20:03:22 +0300
Subject: [PATCH] Cleaned up code and added documentation

---
 src/Control/Monad/Validation.hs | 165 ++++++++++++++++++++++++++++----
 1 file changed, 147 insertions(+), 18 deletions(-)

diff --git a/src/Control/Monad/Validation.hs b/src/Control/Monad/Validation.hs
index 1d34c76..293cb40 100644
--- a/src/Control/Monad/Validation.hs
+++ b/src/Control/Monad/Validation.hs
@@ -3,16 +3,38 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
-module Control.Monad.Validation where
+module Control.Monad.Validation
+  ( ValidationT(..)
+  , runValidationT
+  , runValidationTEither
+  , handleValidationT
+  , vError
+  , vWarning
+  , vErrorL
+  , vWarningL
+  , vZoom
+  , vZoomL
+  , mmSingleton
+  , setMempty
+  , neConcat
+  , textErrors
+  , _MonoidMap
+  , MonoidMap(..)
+  ) where
 
+import Control.Applicative
 import Control.Lens hiding ((.=))
 import Control.Monad.Base
 import Control.Monad.Catch
 import Control.Monad.Except
+import Control.Monad.Fail
 import Control.Monad.State.Strict
+import Control.Monad.Trans.Control
 import Data.Aeson
 import Data.Foldable as F
+import Data.Functor
 import Data.List as L
 import Data.Map.Strict as M
 import Data.Monoid
@@ -20,20 +42,32 @@ 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
+
+-- | Collects all thrown warnings in 'StateT' and errors
+-- in 'ExceptT' into a single value using 'Monoid'.
 newtype ValidationT e m a = ValidationT
   { unValidationT :: ExceptT e (StateT e m) a
   } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
-             , MonadBase b )
+             , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
+             , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
 
 instance MonadTrans (ValidationT e) where
   lift = ValidationT . lift . lift
 
 -- | Map with 'Monoid' instance which 'mappend' its values
+--
+-- This can be used as the `e` in `ValidationT e m a` to provide different
+-- sets of errors and warnings for different keys.
+--
+-- >>> :{
+--   mconcat
+--   [ MonoidMap $ M.fromList [(1, "foo"), (2, "hello, "), (3, "oh no")]
+--   , MonoidMap $ M.fromList [(1, "bar"), (2, "world")]
+--   ]
+-- :}
+-- MonoidMap (fromList [(1,"foobar"),(2,"hello, world"),(3,"oh no")])
 newtype MonoidMap k v = MonoidMap (Map k v)
-  deriving (Eq, Ord, Show, Arbitrary)
+  deriving (Eq, Ord, Show, Arbitrary, Foldable)
 
 makePrisms ''MonoidMap
 
@@ -61,7 +95,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
         , "value" .= v ]
 
 instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
-  parseJSON v = withArray "MonoidMap" go v
+  parseJSON = withArray "MonoidMap" go
     where
       go arr = do
         keyvals <- traverse fromObj arr
@@ -78,14 +112,14 @@ mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
 #endif
 mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
 
--- | Convenient for 'vZoom' as first artument. Will prevent generation
--- of map with 'mempty' values
+-- | Convenient for 'vZoom' as first argument. Will prevent generation
+-- of map with 'mempty' values.
 mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
 mmSingleton k v
   | v == mempty = mempty
   | otherwise   = MonoidMap . M.singleton k $ v
 
--- | Set given value to 'mempty'
+-- | Sets given value to 'mempty'.
 setMempty :: (Monoid s) => ASetter' s a -> a -> s
 setMempty setter a = set setter a mempty
 
@@ -94,12 +128,44 @@ neConcat f a
   | F.null a  = Nothing
   | otherwise = Just $ F.foldr1 f a
 
+-- | Returns the strings, concatanated with @", "@ if the list is not empty.
+--
+-- Returns Nothing if the list is empty
+--
+-- >>> textErrors ["foo", "bar"]
+-- Just "foo, bar"
+--
+-- >>> textErrors ["foo"]
+-- Just "foo"
+--
+-- >>> textErrors []
+-- Nothing
 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'
+-- | Returns 'mempty' instead of error if no warnings have occured.
+-- Returns 'Nothing' as the second element of tuple if computation was
+-- interrupted by 'vError'.
+--
+-- Returns all concatenated errors and warnings and the result if no
+-- errors have occured (warnings could have occured).
+--
+-- >>> :{
+--  runValidationT $ do
+--    vWarning ["warning1"]
+--    vError ["error"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- (["error","warning1"],Nothing)
+--
+-- >>> :{
+--  runValidationT $ do
+--    vWarning ["warning1"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- (["warning1","warning2"],Just 8)
 runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
 runValidationT (ValidationT m) = do
   (res, warnings) <- runStateT (runExceptT m) mempty
@@ -107,6 +173,25 @@ runValidationT (ValidationT m) = do
     Left err -> (err <> warnings, Nothing)
     Right a  -> (warnings, Just a)
 
+-- | Like 'runValidationT' but doesn't return the result
+-- if any warning has occured.
+--
+-- >>> :{
+--  runValidationTEither $ do
+--    vWarning ["warning1"]
+--    vError ["error"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- Left ["error","warning1"]
+--
+-- >>> :{
+--  runValidationTEither $ do
+--    vWarning ["warning1"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- Left ["warning1","warning2"]
 runValidationTEither
   :: (Monoid e, Eq e, Monad m)
   => ValidationT e m a
@@ -117,28 +202,71 @@ runValidationTEither action = do
     Just a | err == mempty -> Right a
     _                      -> Left err
 
+-- | Like 'runValidationTEither', but takes an error handler instead of
+-- returning errors and warnings.
+--
+-- >>> :{
+--  handleValidationT (\_ -> return 11) $ do
+--    vWarning ["warning1"]
+--    vError ["error"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- 11
+--
+-- >>> :{
+--  handleValidationT (\_ -> return 11) $ do
+--    vWarning ["warning1"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- 11
 handleValidationT
   :: (Monoid e, Monad m, Eq e)
   => (e -> m a)
   -> ValidationT e m a
   -> m a
-handleValidationT handler action = do
+handleValidationT handler action =
   runValidationTEither action >>= either handler return
 
--- | Stops further execution of validation
+-- | Stops further execution and appends the given error.
 vError :: (Monad m) => e -> ValidationT e m a
 vError e = ValidationT $ throwError e
 
--- | Does not stop further execution, append warning to
+-- | Does not stop further execution and appends the given warning.
 vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
 vWarning e = ValidationT $ modify' (<> e)
 
+-- | Like 'vError' but allows you to use a setter to insert an error somewhere
+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
+-- combined with all gathered warnings.
 vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
 vErrorL l a = vError $ setMempty l a
 
+-- | Like 'vWarning' but allows you to use a setter to insert an error somewhere
+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
+-- combined with all gathered warnings.
 vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
 vWarningL l a = vWarning $ setMempty l a
 
+-- | Allows you apply a transformation to the "e" in "ValidationT e m x".
+--
+-- >>> :{
+--runValidationT . vZoom (Data.Map.singleton "password errors") $ do
+--  vWarning ["warning1"]
+--  vError ["error"]
+--  vWarning ["warning2"]
+--  return 8
+-- :}
+-- (fromList [("password errors",["error","warning1"])],Nothing)
+--
+-- >>> :{
+--  runValidationT . vZoom (Data.Map.singleton "password errors") $ do
+--    vWarning ["warning1"]
+--    vWarning ["warning2"]
+--    return 8
+-- :}
+-- (fromList [("password errors",["warning1","warning2"])],Just 8)
 vZoom
   :: (Monad m, Monoid a, Monoid b)
   => (a -> b)
@@ -148,11 +276,12 @@ vZoom up action = do
   (err, res) <- lift $ runValidationT action
   case res of
     Nothing -> vError $ up err
-    Just a  -> vWarning (up err) *> return a
+    Just a  -> vWarning (up err) $> a
 
+-- | Like 'vZoom' but takes a setter instead of a function.
 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
+vZoomL l = vZoom (setMempty l)