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 (Int -> VCtx f a -> ShowS
[VCtx f a] -> ShowS
VCtx f a -> String
(Int -> VCtx f a -> ShowS)
-> (VCtx f a -> String) -> ([VCtx f a] -> ShowS) -> Show (VCtx f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall f a. (Show a, Show f) => Int -> VCtx f a -> ShowS
forall f a. (Show a, Show f) => [VCtx f a] -> ShowS
forall f a. (Show a, Show f) => VCtx f a -> String
showList :: [VCtx f a] -> ShowS
$cshowList :: forall f a. (Show a, Show f) => [VCtx f a] -> ShowS
show :: VCtx f a -> String
$cshow :: forall f a. (Show a, Show f) => VCtx f a -> String
showsPrec :: Int -> VCtx f a -> ShowS
$cshowsPrec :: forall f a. (Show a, Show f) => Int -> VCtx f a -> ShowS
Show, VCtx f a -> VCtx f a -> Bool
(VCtx f a -> VCtx f a -> Bool)
-> (VCtx f a -> VCtx f a -> Bool) -> Eq (VCtx f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall f a. (Eq a, Eq f) => VCtx f a -> VCtx f a -> Bool
/= :: VCtx f a -> VCtx f a -> Bool
$c/= :: forall f a. (Eq a, Eq f) => VCtx f a -> VCtx f a -> Bool
== :: VCtx f a -> VCtx f a -> Bool
$c== :: forall f a. (Eq a, Eq f) => VCtx f a -> VCtx f a -> Bool
Eq)
instance Semigroup a => Semigroup (VCtx f a) where
(ValidCtx a1 :: a
a1) <> :: VCtx f a -> VCtx f a -> VCtx f a
<> (ValidCtx a2 :: a
a2) = a -> VCtx f a
forall f a. a -> VCtx f a
ValidCtx (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a2)
(ValidCtx a1 :: a
a1) <> (DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs a2 :: a
a2) = [f] -> Map [Name] [f] -> a -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a2)
(ValidCtx _) <> (RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs a1 :: a
a1) <> (ValidCtx a2 :: a
a2) = [f] -> Map [Name] [f] -> a -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a2)
(DisputedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1 a1 :: a
a1) <> (DisputedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2 a2 :: a
a2) =
[f] -> Map [Name] [f] -> a -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2) (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a2)
(DisputedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1 _) <> (RefutedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
(RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) <> (ValidCtx _) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(RefutedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1) <> (DisputedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2 _) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
(RefutedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1) <> (RefutedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
instance Monoid a => Monoid (VCtx f a) where
mempty :: VCtx f a
mempty = a -> VCtx f a
forall f a. a -> VCtx f a
ValidCtx a
forall a. Monoid a => a
mempty
instance Functor (VCtx f) where
fmap :: (a -> b) -> VCtx f a -> VCtx f b
fmap f :: a -> b
f (ValidCtx a :: a
a) = b -> VCtx f b
forall f a. a -> VCtx f a
ValidCtx (a -> b
f a
a)
fmap f :: a -> b
f (DisputedCtx gps :: [f]
gps lfs :: Map [Name] [f]
lfs a :: a
a) = [f] -> Map [Name] [f] -> b -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gps Map [Name] [f]
lfs (a -> b
f a
a)
fmap _ (RefutedCtx gps :: [f]
gps lfs :: Map [Name] [f]
lfs) = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gps Map [Name] [f]
lfs
instance Applicative (VCtx f) where
pure :: a -> VCtx f a
pure = a -> VCtx f a
forall f a. a -> VCtx f a
ValidCtx
(ValidCtx fn :: a -> b
fn) <*> :: VCtx f (a -> b) -> VCtx f a -> VCtx f b
<*> (ValidCtx a :: a
a) = b -> VCtx f b
forall f a. a -> VCtx f a
ValidCtx (a -> b
fn a
a)
(ValidCtx fn :: a -> b
fn) <*> (DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs a :: a
a) = [f] -> Map [Name] [f] -> b -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs (a -> b
fn a
a)
(ValidCtx _) <*> (RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs fn :: a -> b
fn) <*> (ValidCtx a :: a
a) = [f] -> Map [Name] [f] -> b -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs (a -> b
fn a
a)
(DisputedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1 fn :: a -> b
fn) <*> (DisputedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2 a :: a
a) =
[f] -> Map [Name] [f] -> b -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2) (a -> b
fn a
a)
(DisputedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1 _) <*> (RefutedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2) = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
(RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) <*> (ValidCtx _) = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(RefutedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1) <*> (DisputedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2 _) = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
(RefutedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1) <*> (RefutedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2) = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
instance Monad (VCtx f) where
(ValidCtx a :: a
a) >>= :: VCtx f a -> (a -> VCtx f b) -> VCtx f b
>>= fn :: a -> VCtx f b
fn = a -> VCtx f b
fn a
a
(RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) >>= _ = [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs a :: a
a) >>= fn :: a -> VCtx f b
fn = case a -> VCtx f b
fn a
a of
ValidCtx b :: b
b -> [f] -> Map [Name] [f] -> b -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs b
b
DisputedCtx gfs' :: [f]
gfs' lfs' :: Map [Name] [f]
lfs' b :: b
b -> [f] -> Map [Name] [f] -> b -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx ([f]
gfs [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs') (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs Map [Name] [f]
lfs') b
b
RefutedCtx gfs' :: [f]
gfs' lfs' :: Map [Name] [f]
lfs' -> [f] -> Map [Name] [f] -> VCtx f b
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs') (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs Map [Name] [f]
lfs')
aggregateFailures :: VCtx f a -> VCtx f b -> VCtx f a
aggregateFailures :: VCtx f a -> VCtx f b -> VCtx f a
aggregateFailures a :: VCtx f a
a b :: VCtx f b
b = VCtx f a
a VCtx f a -> VCtx f b -> VCtx f a
forall f a b. VCtx f a -> VCtx f b -> VCtx f a
<! VCtx f b
b
(<!) :: VCtx f a -> VCtx f b -> VCtx f a
(ValidCtx a :: a
a) <! :: VCtx f a -> VCtx f b -> VCtx f a
<! (ValidCtx _) = a -> VCtx f a
forall f a. a -> VCtx f a
ValidCtx a
a
(ValidCtx a :: a
a) <! (DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs _) = [f] -> Map [Name] [f] -> a -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs a
a
(ValidCtx _) <! (RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(DisputedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs a :: a
a) <! (ValidCtx _) = [f] -> Map [Name] [f] -> a -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx [f]
gfs Map [Name] [f]
lfs a
a
(DisputedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1 a :: a
a) <! (DisputedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2 _) = [f] -> Map [Name] [f] -> a -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> a -> VCtx f a
DisputedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2) a
a
(DisputedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1 _) <! (RefutedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
(RefutedCtx gfs :: [f]
gfs lfs :: Map [Name] [f]
lfs) <! (ValidCtx _) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx [f]
gfs Map [Name] [f]
lfs
(RefutedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1) <! (DisputedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2 _) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
(RefutedCtx gfs1 :: [f]
gfs1 lfs1 :: Map [Name] [f]
lfs1) <! (RefutedCtx gfs2 :: [f]
gfs2 lfs2 :: Map [Name] [f]
lfs2) = [f] -> Map [Name] [f] -> VCtx f a
forall f a. [f] -> Map [Name] [f] -> VCtx f a
RefutedCtx ([f]
gfs1 [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
<> [f]
gfs2) (([f] -> [f] -> [f])
-> Map [Name] [f] -> Map [Name] [f] -> Map [Name] [f]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith [f] -> [f] -> [f]
forall a. Semigroup a => a -> a -> a
(<>) Map [Name] [f]
lfs1 Map [Name] [f]
lfs2)
testMatch :: Eq a => f -> a -> a -> Maybe f
testMatch :: f -> a -> a -> Maybe f
testMatch f :: f
f a1 :: a
a1 a2 :: a
a2 = case a
a1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a2 of
True -> Maybe f
forall a. Maybe a
Nothing
False -> f -> Maybe f
forall a. a -> Maybe a
Just f
f