@@ -0,0 +1,153 @@
1+
2+module Common.Validation where
3+
4+import Control.Lens hiding ((.=))
5+import Control.Monad.Base
6+import Control.Monad.Catch
7+import Control.Monad.Except
8+import Control.Monad.State.Strict
9+import Control.Monad.Trans.Lift.Local
10+import Data.Aeson
11+import Data.Foldable as F
12+import Data.List as L
13+import Data.Map.Strict as M
14+import Data.Monoid
15+import Data.Text as T
16+import Data.Vector as V
17+import Test.QuickCheck
18+
19+-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
20+-- through ExceptT to single value using Monoid
21+-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
22+newtype ValidationT e m a = ValidationT
23+ { unValidationT :: ExceptT e (StateT e m) a
24+ } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
25+ , MonadBase b )
26+
27+instance MonadTrans (ValidationT e) where
28+ lift = ValidationT . lift . lift
29+
30+instance LiftLocal (ValidationT e) where
31+ liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
32+
33+-- | Map with 'Monoid' instance which 'mappend' its values
34+newtype MonoidMap k v = MonoidMap (Map k v)
35+ deriving (Eq, Ord, Show, Arbitrary)
36+
37+makePrisms ''MonoidMap
38+
39+type instance IxValue (MonoidMap k v) = v
40+type instance Index (MonoidMap k v) = k
41+instance (Ord k) => Ixed (MonoidMap k v) where
42+ ix key = _MonoidMap . ix key
43+instance (Ord k) => At (MonoidMap k v) where
44+ at key = _MonoidMap . at key
45+
46+instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
47+ mempty = MonoidMap M.empty
48+ mappend (MonoidMap a) (MonoidMap b) =
49+ MonoidMap $ M.unionWith (<>) a b
50+
51+instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
52+ toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
53+ where
54+ toObj (k, v) = object
55+ [ "id" .= k
56+ , "value" .= v ]
57+
58+instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
59+ parseJSON v = withArray "MonoidMap" go v
60+ where
61+ go arr = do
62+ keyvals <- traverse fromObj arr
63+ return $ MonoidMap $ M.fromList $ V.toList keyvals
64+ fromObj objV = flip (withObject "element of MonoidMap") objV $ \obj -> do
65+ key <- obj .: "id"
66+ val <- obj .: "value"
67+ return (key, val)
68+
69+-- | Convenient for 'vZoom' as first artument. Will prevent generation
70+-- of map with 'mempty' values
71+mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
72+mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
73+
74+-- | Set given value to 'mempty'
75+setMempty :: (Monoid s) => ASetter' s a -> a -> s
76+setMempty setter a = set setter a mempty
77+
78+memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
79+memptyWrap b f a
80+ | a == mempty = b
81+ | otherwise = f a
82+
83+-- | If given container is not 'mempty', then use given function to
84+-- append all its elements and return 'Just' result
85+neConcat
86+ :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
87+ => (a -> a -> a)
88+ -> f a
89+ -> Maybe a
90+neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)
91+
92+textErrors :: [Text] -> Maybe Text
93+textErrors = neConcat (\a b -> a <> ", " <> b)
94+
95+-- | Returns `mempty` instead of error if no warnings was occured. So, your
96+-- error should have `Eq` instance to detect that any error was occured. Returns
97+-- Nothing for second element of tuple if compuration was interruped by 'vError'
98+runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
99+runValidationT (ValidationT m) = do
100+ (res, warnings) <- runStateT (runExceptT m) mempty
101+ return $ case res of
102+ Left err -> (err <> warnings, Nothing)
103+ Right a -> (warnings, Just a)
104+
105+runValidationTEither
106+ :: (Monoid e, Eq e, Monad m)
107+ => ValidationT e m a
108+ -> m (Either e a)
109+runValidationTEither action = do
110+ (err, res) <- runValidationT action
111+ return $ case res of
112+ Just a | err == mempty -> Right a
113+ _ -> Left err
114+
115+handleValidationT
116+ :: (Monoid e, Monad m, Eq e)
117+ => (e -> m a)
118+ -> ValidationT e m a
119+ -> m a
120+handleValidationT handler action = do
121+ runValidationTEither action >>= either handler return
122+
123+-- | Stops further execution of validation
124+vError :: (Monad m) => e -> ValidationT e m a
125+vError e = ValidationT $ throwError e
126+
127+-- | Does not stop further execution, append warning to
128+vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
129+vWarning e = ValidationT $ modify' (<> e)
130+
131+vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
132+vErrorL l a = vError $ setMempty l a
133+
134+vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
135+vWarningL l a = vWarning $ setMempty l a
136+
137+vZoom
138+ :: (Monad m, Monoid a, Monoid b)
139+ => (a -> b)
140+ -> ValidationT a m x
141+ -> ValidationT b m x
142+vZoom up action = do
143+ (err, res) <- lift $ runValidationT action
144+ case res of
145+ Nothing -> vError $ up err
146+ Just a -> vWarning (up err) *> return a
147+
148+vZoomL
149+ :: (Monad m, Monoid a, Monoid b)
150+ => ASetter' b a
151+ -> ValidationT a m x
152+ -> ValidationT b m x
153+vZoomL l action = vZoom (setMempty l) action