{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
module Control.Validation.Class {-# DEPRECATED "This module is no longer supported." #-}(
    -- * Checkable
    -- $checkable
    validate, validate',
    CheckChain(..), overChain, (+?+), singleChain,
    Validatable(..),
    TrivialCheck(..),

    -- ** Helper for deriving Validatable
    -- $derivHelper

    -- * Reexports

) where

import           Control.Monad.Morph                  (MFunctor (..))
import           Control.Validation.Check
import           Data.Foldable                        (fold)
import           Data.Functor.Contravariant           (Contravariant (..))
import           Data.Functor.Contravariant.Compose   (ComposeFC (..))
import           Data.Functor.Contravariant.Divisible (Decidable (..),
                                                       Divisible (..))
import           Data.Functor.Identity                (Identity (..))
import           Data.Int                             (Int16, Int32, Int64,
                                                       Int8)
import           Data.Kind                            (Type)
import           Data.Sequence                        (Seq)
import           Data.Void                            (Void)
import           GHC.Generics
------------------------------------------------------------------------------------------------------
-- $checkable
-- = The 'Validatable' typeclass.
-- /Note/: It is not inteded to be used for testing of
-- internal integrity of types, i.e. it does not check if a 'Text' has a valid internal
-- representation. For testing internal integrity please use the package
--  (validity)[https://stackage.org/package/validity].
-- The typeclass is split up into three parts:
--
-- * 'checkChain':  A list of checks that will be performed in
-- that order. This has to be provided to give an instance.
-- For the reason why it is given as a list and the checks are
-- not combined via '(<>)', see the point for `isValid`.
--
-- * 'defaulCheck': A check performing all checks of 'checkChain'
--
-- > defaultCheck = fold checkChain
--
-- * 'isValid':     A function determining whether a value is valid.
-- This functions stops checking after the first of the checks
-- from 'checkChain' fails .This function is the reason why we
-- need the 'checkChain', as a 'Check' constructed by '(<>)'
-- goes through all operands, so `passed $ runCheck (shortCheck <> longCheck) unvalidatedInput`
-- evalutes the argument with `longCheck` even if `shortCheck` failed.
-- But if we define
--
-- > instance Validatable e m T where
-- >   checkChain = CheckChain [ shortCheck, longCheck ]
--
-- then `isValid unvalidatedInput` stops after `shortCheck` failed.

newtype CheckChain (e :: Type) (m :: Type -> Type) (a :: Type) =
    CheckChain { runCheckChain :: [ Check e m a ] }
        deriving newtype ( Monoid, Semigroup )
        deriving (Contravariant, Divisible, Decidable) via (ComposeFC [] (Check e m))

instance MFunctor (CheckChain e) where
  hoist f = overChain (hoist f)

overChain :: (Check e m a -> Check e' n b) -> CheckChain e m a -> CheckChain e' n b
overChain f = CheckChain . fmap f . runCheckChain

-- | Convenience synonym.
{-# INLINE (+?+) #-}
(+?+) :: CheckChain e m a -> CheckChain e m a -> CheckChain e m a
(+?+) = (<>)
infixr 5 +?+ -- so it behaves like list concatenation

{-# INLINE emptyChain #-}
-- | The checkchain that contains no checks
emptyChain :: CheckChain e m a
emptyChain = mempty


{-# INLINE singleChain #-}
-- | Constructs a chain with only one check.
singleChain :: Check e m a -> CheckChain e m a
singleChain x = CheckChain [ x ]


-- | These are the functions used to validate data. Return either a validated result or a sequence of all validation errors that occured.
{-# INLINABLE validate' #-}
validate' :: Validatable e Identity a => Unvalidated a -> Either (Seq e) a
validate' u =
    checkResultToEither (unsafeValidate u)
    . runIdentity
    . runCheck defaultCheck
    $ u

{-# INLINABLE validate #-}
validate :: (Validatable e m a, Functor m) => Unvalidated a -> m (Either (Seq e) a)
validate u =
    fmap (checkResultToEither $ unsafeValidate u)
    . runCheck defaultCheck
    $ u



class Validatable (e :: Type) (m :: Type -> Type) (a :: Type) | a -> m, a -> e where

    checkChain :: CheckChain e m a
    default checkChain :: (Generic a, GValidatable e m (Rep a)) => CheckChain e m a
    checkChain = contramap from gCheckChain

    defaultCheck :: Check e m a
    default defaultCheck :: Applicative m => Check e m a
    defaultCheck = fold . runCheckChain $ checkChain

    isValid ::  Unvalidated a -> m Bool
    default isValid :: Applicative m => Unvalidated a -> m Bool
    isValid u = fmap (all passed) $ traverse (($ u) . runCheck) $ runCheckChain checkChain




deriving via TrivialCheck ()         instance Validatable Void Identity ()
deriving via TrivialCheck Bool       instance Validatable Void Identity Bool
deriving via TrivialCheck Char       instance Validatable Void Identity Char
deriving via TrivialCheck Double     instance Validatable Void Identity Double
deriving via TrivialCheck Float      instance Validatable Void Identity Float
deriving via TrivialCheck Int        instance Validatable Void Identity Int
deriving via TrivialCheck Int8       instance Validatable Void Identity Int8
deriving via TrivialCheck Int16      instance Validatable Void Identity Int16
deriving via TrivialCheck Int32      instance Validatable Void Identity Int32
deriving via TrivialCheck Int64      instance Validatable Void Identity Int64
deriving via TrivialCheck Integer    instance Validatable Void Identity Integer

instance (Validatable e m a, Applicative m) => (Validatable e m (Maybe a)) where
    checkChain = traverseWithCheck `overChain` checkChain

instance (Validatable e m b, Validatable e m a, Applicative m) => Validatable e m (Either a b) where
    checkChain = traverseWithCheck `overChain` checkChain

instance (Validatable e m a, Applicative m) => (Validatable e m [a]) where
    checkChain = traverseWithCheck `overChain` checkChain


------------------------------------------------------------------------------------------------------
-- $derivHelper
-- == Helper for deriving Validatable
-- Intended for use with `-XDerivingVia` like
--
-- > data X = X Int
-- >     deriving (Validatable Void Identity) via (TrivialCheck X)
-- > -- or with `-XStandaloneDeriving`
-- > data Y = Y String
-- > deriving via (TrivialCheck Y) instance (Validatable Void Identity Y)


newtype TrivialCheck a = TrivialCheck { unTrivialCheck :: a }

instance Validatable Void Identity (TrivialCheck a) where
    {-# INLINE checkChain #-}
    checkChain = emptyChain
    {-# INLINE defaultCheck #-}
    defaultCheck = mempty
    {-# INLINE isValid #-}
    isValid = const (Identity True)





------------------------------------------------------------------------------------------------------
-- The generic instance

class GValidatable (e :: Type) (m :: Type -> Type) (rep :: k -> Type) | rep -> m, rep -> e where
    gCheckChain :: CheckChain e m (rep x)

instance GValidatable Void Identity V1 where
    gCheckChain = mempty

instance GValidatable Void Identity U1 where
    gCheckChain = mempty

instance Validatable e m a => GValidatable e m  (K1 i a) where
    gCheckChain :: CheckChain e m (K1 i a x)
    gCheckChain = contramap unK1 checkChain

instance (Applicative m, GValidatable e m f, GValidatable e m g) => GValidatable e m (f :*: g) where
    gCheckChain = divide id_tup gCheckChain gCheckChain
        where id_tup (x :*: y) = (x, y)

instance (GValidatable e m f, GValidatable e m g, Applicative m) => GValidatable e m (f :+: g) where
    gCheckChain = choose id_sum gCheckChain gCheckChain
        where id_sum = \case
                L1 l -> Left l
                R1 r -> Right r

instance (GValidatable e m rep) => GValidatable e m (M1 i c rep) where
    gCheckChain = contramap unM1 gCheckChain