{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
module Control.Validation.Patch(

-- * Patch
-- $patch
Patch(..), patch, noPatch,
-- * CheckPatch
-- $checkPatch
CheckPatch(..), CheckPatch', runCheckPatch, runCheckPatch',
liftPatch, liftNoPatch, demotePatch, mapErrorPatch, overCheck, Patched(..), validateByPatch, validateByPatch',

-- * Lens-variants of functions on 'Check's
-- $lens-variants
contramapL, chooseL, divideL,

-- * Construction of 'CheckPatch'es
-- $construction

    checkingPatch, checkingPatch',
    -- $constructionByPredicate
    testPatch,
    testPatch',
    testPatch_,
    testPatch'_,
    testPatchDefault,


    MultiCheckPatch,
    constructorCheckPatch,
    joinMultiCheckPatch,
    mapErrorsWithInfoPatch,
   
    -- * Reexports
    NP(..), DatatypeName, ConstructorName, FieldName
 ) where


import           Control.Validation.Check             (Check(..), unsafeValidate,
                                                       CheckResult (Passed),
                                                       Unvalidated,
                                                       failsWith, mapError, checking, unsafeValidate,
                                                       unvalidated, validateBy)
import Control.Validation.Internal.SOP
import           Data.Bifunctor                       (Bifunctor (second),
                                                       first)
import Generics.SOP as SOP(POP(..), unPOP, hliftA2, unK, NP(..), Generic(..), HasDatatypeInfo(..), DatatypeName, ConstructorName, FieldName, NS(..), SListI, hcexpand, hpure, SOP(..), I(..), unSOP, unI, hd, tl)
import Data.Foldable (Foldable (fold))
import Data.Functor ((<&>))
import Data.Functor.Contravariant (Contravariant (contramap))
import Data.Functor.Identity (Identity(..))
import Data.Monoid (Ap (..))
import Data.Sequence as Seq (Seq)
import qualified GHC.Generics  as GHC(Generic)
import Data.Proxy(Proxy(..))
import Lens.Micro (Lens')
import Lens.Micro.Extras (view)
import Control.Monad ((<=<))
import Data.Bitraversable (Bitraversable(bitraverse))

-- $checkPatch
-- The 'CheckPatch' type is similar to 'Check' but accumulates a function that "fixes" your data i.e. corrects it where it fails a 'Check'. To do so, some
-- of the combinators take 'Lens'es instead of normal functions (see below). To lift a normal 'Check' to a 'CheckPatch' use 'checkPatch'.
-- to validate and fix your data with a 'CheckPatch' use 'validateByPatch'.

newtype Patch a = Patch { runPatch :: a -> Maybe a }

instance Semigroup (Patch a) where
  {-# INLINE (<>) #-}
  Patch f <> Patch g = Patch (f <=< g)

instance Monoid (Patch a) where
  {-# INLINE mempty #-}
  mempty = Patch Just


-- | Helper functions to construct Patches.
patch :: (a -> a) -> Patch a
patch = Patch . (Just . )

noPatch :: Patch a
noPatch = Patch $ const Nothing


-- | A 'Check' that also corrects the errors in your data.
newtype CheckPatch e m a = CheckPatch (Check (e, Patch a) m a)
  deriving (Monoid, Semigroup)
type CheckPatch' e = CheckPatch e Identity

runCheckPatch :: CheckPatch e m a -> Unvalidated a -> m (CheckResult (e, Patch a))
runCheckPatch (CheckPatch p) = runCheck p

runCheckPatch' :: CheckPatch' e a -> Unvalidated a -> CheckResult (e, Patch a)
runCheckPatch' (CheckPatch p) = runIdentity . runCheck p

overCheck :: (Check (e, Patch a) m a -> Check (e', Patch a') m' a') -> CheckPatch e m a -> CheckPatch e' m' a'
overCheck f (CheckPatch c) = CheckPatch (f c)



-- | Lift a 'Check' to a 'CheckPatch' without a patch.
liftNoPatch :: Functor m => Check e m a -> CheckPatch e m a
liftNoPatch = CheckPatch .  mapError (, noPatch)


-- | Lift a 'Check' to a 'CheckPatch' with a patch
liftPatch :: Functor m => (a -> Maybe a) -> Check e m a -> CheckPatch e m a
liftPatch p = CheckPatch . mapError (, Patch p)

-- | Demote a 'CheckPatch' into a 'Check' by throwing the patch away
demotePatch :: Functor m => CheckPatch e m a -> Check e m a
demotePatch (CheckPatch c) = mapError fst c

newtype Patched a = Patched { getPatched :: a } deriving (Show, Eq, Read, Generic)
-- | 'validateByPatch' takes a 'CheckPatch' and the unvalidated data and either returns the validated data or returns the errors in the data
-- and ─ if a fix exists ─  the fixed data.
validateByPatch :: forall m e a. Functor m => CheckPatch e m a -> Unvalidated a -> m (Either (Seq e, Maybe (Patched a)) a)
validateByPatch (CheckPatch c) v = applyChanges <$> validateBy c v
  where
    applyChanges :: Either (Seq (e, Patch a)) a -> Either (Seq e, Maybe (Patched a)) a
    applyChanges (Right a) = Right a
    applyChanges (Left s) =
      let errs = fmap fst s :: Seq e
          x' =  Patched <$> runPatch (fold . fmap snd $ s) (unsafeValidate v)
       in Left (errs, x')

-- | 'validateByPatch' with trivial context
validateByPatch' :: CheckPatch' e a -> Unvalidated a -> Either (Seq e, Maybe (Patched a)) a
validateByPatch' c d = runIdentity . validateByPatch c $ d

mapErrorPatch :: Functor m => (e -> e') -> CheckPatch e m a -> CheckPatch e' m a
mapErrorPatch f (CheckPatch c) = CheckPatch $ mapError (first f) c


-- * Variants of functions from "Control.Validation.Check"
-- $lens-variants
-- The functions 'contramapL', 'chooseL' and 'divideL' are the counterparts that take a lens instead of a simple function so they can patch their data if needed.
contramapL :: Functor m => Lens' s a -> CheckPatch e m a -> CheckPatch e m s
contramapL l =
  overCheck $ mapError (second $ Patch . l . runPatch)
  . contramap (view l)


traverseFirst :: forall f x x' y b. (Bitraversable b, Applicative f) => (x -> f x') -> b x y -> f (b x' y)
traverseFirst = flip bitraverse pure

traverseSecond :: (Bitraversable b, Applicative f) => (y -> f y') -> b x y -> f (b x y')
traverseSecond = bitraverse pure


chooseL :: forall m a b c e. (Functor m) => (Lens' a (Either b c)) -> CheckPatch e m b -> CheckPatch e m c -> CheckPatch e m a
chooseL p (CheckPatch c1) (CheckPatch c2) = CheckPatch $ Check $
  either
    (\input ->
       fmap (second $ \(Patch f) -> Patch (p $ traverseFirst f))
         <$> runCheck c1 (unvalidated input)                         )
    (\input ->
        fmap (second $ \(Patch f) -> Patch (p $ traverseSecond f))
             <$> runCheck c2 (unvalidated input)
       )
  . view p
  . unsafeValidate


divideL :: forall m a b c e. (Applicative m) => (Lens' a (b, c)) -> CheckPatch e m b -> CheckPatch e m c -> CheckPatch e m a
divideL p (CheckPatch c1) (CheckPatch c2) = CheckPatch $ Check $ \v -> case view p $ unsafeValidate v of
  (b, c) -> getAp $
    ( Ap $ fmap (second $ \(Patch f) -> Patch (p $ traverseFirst f))
      <$> runCheck c1 (unvalidated b))
    <>
      (Ap $ fmap (second $ \(Patch f) -> Patch (p $ traverseSecond f))
       <$> runCheck c2 (unvalidated c))







-- ** Construction of 'CheckPatch'es
-- $construction
-- Patch-variants for construction-functions. Functions have a `Patch` appended (e.g. 'test_' ~> 'testPatch_') and operators have an additional exclamation mark after the question mark
-- (e.g. '?>>' ~> '?!>>')
-- For documentation see "Control.Valiation.Check".
checkingPatch :: Functor m => (a -> (Maybe a, m (CheckResult e))) -> CheckPatch e m a
checkingPatch f = CheckPatch $ mapError ((, Patch $ fst . f)) $ checking (snd . f)



checkingPatch' :: (a -> (Maybe a, CheckResult e)) -> CheckPatch' e a
checkingPatch' = checkingPatch . (second Identity .)

testPatch' :: Applicative m => (a -> Bool) -> (a -> e) -> Patch a -> CheckPatch e m a
testPatch' p onErr fix = CheckPatch . Check $ \x -> pure $ if p . unsafeValidate $ x
    then Passed
    else failsWith (onErr $ unsafeValidate x, fix)
infix 7 `testPatch'`


{-# INLINE testPatch'_ #-}
testPatch'_ :: Applicative m => (a -> Bool) -> e -> Patch a -> CheckPatch e m a
testPatch'_ p err fix = testPatch' p (const err) fix
infix 7 `testPatch'_`

testPatch :: Functor m => (a -> m Bool) -> (a -> e) -> Patch a -> CheckPatch e m a
testPatch p onErr fix = CheckPatch . Check $ \x -> p (unsafeValidate x) <&> \case
    True  -> Passed
    False -> failsWith (onErr . unsafeValidate $ x, fix)
infix 7 `testPatch`

{-# INLINE testPatch_ #-}
testPatch_ :: Monad m => (a -> m Bool) -> e -> Patch a  -> CheckPatch e m a
testPatch_ p err fix = testPatch p (const err) fix
infix 7 `testPatch_`




-- | Patch by replacing with default value
testPatchDefault :: Applicative m => (a -> m Bool) -> (a -> e) -> a -> CheckPatch e m a
testPatchDefault p err def = testPatch p err (Patch $ const $ Just def)



-- * Multi-'CheckPatch'es
-- $multiCheckPatch

-- | A "Multi"-'CheckPatch' for an ADT, one 'CheckPatch e m' for each field of each constructor, organized in Lists (see examples for construction)
type MultiCheckPatch e m a =  NP (NP (CheckPatch e m)) (Code a)




-- | Combine all 'CheckPatch's from a 'MultiCheckPatch' into a single 'CheckPatch' for the datatype 'a' (given it has a 'Generic' instance).
joinMultiCheckPatch :: forall a m e. (Applicative m, SOP.Generic a)
                                  => MultiCheckPatch e m a
                                  -> CheckPatch e m a
joinMultiCheckPatch = contramapL sopLensTo . joinCheckPatchPOP


-- | Change the error of a 'MultiCheckPatch' using the information about the datatype.
mapErrorsWithInfoPatch :: forall e e' a m. (Functor m, HasDatatypeInfo a) => Proxy a -> (DatatypeName -> ConstructorName -> FieldName -> e -> e') -> MultiCheckPatch e m a -> MultiCheckPatch e' m a
mapErrorsWithInfoPatch p f = unPOP . hliftA2 (mapErrorPatch . unK) (errMsgPOP p f) . POP



constructorCheckPatch :: forall a m e xs. (Applicative m, Generic a)
                                              => (NP (CheckPatch e m) xs -> NS (NP (CheckPatch e m)) (Code a)) -- ^ The function deciding the constructor, 'Z' for the zeroth, 'S . Z' for the first, etc.
                                              -> NP (CheckPatch e m) xs -- ^ Product of 'CheckPatches', one for each constructor
                                              -> CheckPatch e m a
constructorCheckPatch f = contramapL sopLensTo .  joinCheckPatchPOP . hcexpand (Proxy @SListI) (hpure  mempty) . f


-- internal functions

joinCheckPatchPOP :: forall e m xss. (Applicative m)
                       => NP (NP (CheckPatch e m)) xss
                       -> CheckPatch e m (SOP I xss)
joinCheckPatchPOP Nil = mempty
joinCheckPatchPOP (ps :* pss) = CheckPatch . Check $ \uxss -> case unSOP $ unsafeValidate uxss of
  Z xs -> changePatch (\p -> fmap SOP . tZ p . unSOP) $ runCheckPatch (joinCheckPatchNP ps) (unvalidated xs)
  S xss -> changePatch (\p -> fmap SOP . tS (fmap unSOP . p . SOP) . unSOP)
                $ runCheckPatch (joinCheckPatchPOP pss) (unvalidated $ SOP xss)


joinCheckPatchNP :: forall e m xs. (Applicative m) => NP (CheckPatch e m) xs -> CheckPatch e m (NP I xs)
joinCheckPatchNP Nil = mempty
joinCheckPatchNP (p :* ps) =
  CheckPatch $ Check $ \uxs ->
    let h = changePatch (tH . tI) $ runCheckPatch p
                                    . fmap (unI . hd)
                                    $ uxs
        t = changePatch tT $ runCheckPatch (joinCheckPatchNP ps) . fmap tl $ uxs
    in getAp $ Ap h <> Ap t



joinCheckPatchNS :: forall e m xs. Applicative m =>  NP (CheckPatch e m) xs -> CheckPatch e m (NS I xs)
joinCheckPatchNS Nil = mempty
joinCheckPatchNS (p :* ps) = CheckPatch $ Check $ \uxs -> case unsafeValidate uxs of
  Z (I x) -> changePatch (tZ . tI) $  runCheckPatch p . unvalidated $ x
  S t     -> changePatch tS . runCheckPatch (joinCheckPatchNS ps) . unvalidated $ t




changePatch :: Functor m => ((a -> Maybe a) -> (b -> Maybe b)) -> m (CheckResult (e, Patch a)) -> m (CheckResult (e, Patch b))
changePatch f = fmap . fmap . fmap $ Patch . f . runPatch