module Data.Validation.Internal where

------------------------------------------------------------------------------------------------------------------------
import Prelude
import Data.Map
import Language.Haskell.TH (Name)
------------------------------------------------------------------------------------------------------------------------

-- | A type that holds aggregated validation failures.
data VCtx f a 
  = ValidCtx a -- ^ A value that is assumed to be valid.
  | DisputedCtx [f] (Map [Name] [f]) a -- ^ A value that has failures but can continue to be validated.
  | RefutedCtx [f] (Map [Name] [f]) -- ^ A value that has failures and cannot be validated further.
  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')

-- | Takes the failures from the second parameter and adds them to the first.
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

-- | Takes the failures from the right-hand-side, if any, and adds them to the left-hand-side.
(<!) :: 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