module Data.Validation.Internal where
import Prelude
import Data.Map
import Language.Haskell.TH (Name)
data VCtx f a
= ValidCtx a
| DisputedCtx [f] (Map [Name] [f]) a
| RefutedCtx [f] (Map [Name] [f])
deriving (Show, Eq)
instance Semigroup a => Semigroup (VCtx f a) where
(ValidCtx a1) <> (ValidCtx a2) = ValidCtx (a1 <> a2)
(ValidCtx a1) <> (DisputedCtx gfs lfs a2) = DisputedCtx gfs lfs (a1 <> a2)
(ValidCtx _) <> (RefutedCtx gfs lfs) = RefutedCtx gfs lfs
(DisputedCtx gfs lfs a1) <> (ValidCtx a2) = DisputedCtx gfs lfs (a1 <> a2)
(DisputedCtx gfs1 lfs1 a1) <> (DisputedCtx gfs2 lfs2 a2) =
DisputedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) (a1 <> a2)
(DisputedCtx gfs1 lfs1 _) <> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
(RefutedCtx gfs lfs) <> (ValidCtx _) = RefutedCtx gfs lfs
(RefutedCtx gfs1 lfs1) <> (DisputedCtx gfs2 lfs2 _) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
(RefutedCtx gfs1 lfs1) <> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
instance Monoid a => Monoid (VCtx f a) where
mempty = ValidCtx mempty
instance Functor (VCtx f) where
fmap f (ValidCtx a) = ValidCtx (f a)
fmap f (DisputedCtx gps lfs a) = DisputedCtx gps lfs (f a)
fmap _ (RefutedCtx gps lfs) = RefutedCtx gps lfs
instance Applicative (VCtx f) where
pure = ValidCtx
(ValidCtx fn) <*> (ValidCtx a) = ValidCtx (fn a)
(ValidCtx fn) <*> (DisputedCtx gfs lfs a) = DisputedCtx gfs lfs (fn a)
(ValidCtx _) <*> (RefutedCtx gfs lfs) = RefutedCtx gfs lfs
(DisputedCtx gfs lfs fn) <*> (ValidCtx a) = DisputedCtx gfs lfs (fn a)
(DisputedCtx gfs1 lfs1 fn) <*> (DisputedCtx gfs2 lfs2 a) =
DisputedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) (fn a)
(DisputedCtx gfs1 lfs1 _) <*> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
(RefutedCtx gfs lfs) <*> (ValidCtx _) = RefutedCtx gfs lfs
(RefutedCtx gfs1 lfs1) <*> (DisputedCtx gfs2 lfs2 _) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
(RefutedCtx gfs1 lfs1) <*> (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
instance Monad (VCtx f) where
(ValidCtx a) >>= fn = fn a
(RefutedCtx gfs lfs) >>= _ = RefutedCtx gfs lfs
(DisputedCtx gfs lfs a) >>= fn = case fn a of
ValidCtx b -> DisputedCtx gfs lfs b
DisputedCtx gfs' lfs' b -> DisputedCtx (gfs <> gfs') (unionWith (<>) lfs lfs') b
RefutedCtx gfs' lfs' -> RefutedCtx (gfs <> gfs') (unionWith (<>) lfs lfs')
aggregateFailures :: VCtx f a -> VCtx f b -> VCtx f a
aggregateFailures a b = a <! b
(<!) :: VCtx f a -> VCtx f b -> VCtx f a
(ValidCtx a) <! (ValidCtx _) = ValidCtx a
(ValidCtx a) <! (DisputedCtx gfs lfs _) = DisputedCtx gfs lfs a
(ValidCtx _) <! (RefutedCtx gfs lfs) = RefutedCtx gfs lfs
(DisputedCtx gfs lfs a) <! (ValidCtx _) = DisputedCtx gfs lfs a
(DisputedCtx gfs1 lfs1 a) <! (DisputedCtx gfs2 lfs2 _) = DisputedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2) a
(DisputedCtx gfs1 lfs1 _) <! (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
(RefutedCtx gfs lfs) <! (ValidCtx _) = RefutedCtx gfs lfs
(RefutedCtx gfs1 lfs1) <! (DisputedCtx gfs2 lfs2 _) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
(RefutedCtx gfs1 lfs1) <! (RefutedCtx gfs2 lfs2) = RefutedCtx (gfs1 <> gfs2) (unionWith (<>) lfs1 lfs2)
testMatch :: Eq a => f -> a -> a -> Maybe f
testMatch f a1 a2 = case a1 == a2 of
True -> Nothing
False -> Just f