{-|
Module      : Validation
Description : Validation types/typeclass that allow for effectful validation and easy composition.
Copyright   : (c) Fabian Birkmann 2020
License     : GPL-3
Maintainer  : 99fabianb@sis.gl
Stability   : experimental
Portability : POSIX

Types and functions to check properties of your data. To make best use of these functions you should check out "Data.Functor.Contravariant". For documentation see the (README)[https://gitlab.com/Birkmann/validation-check/-/blob/master/README.md].
-}
{-# LANGUAGE 
 PolyKinds, TypeOperators, LambdaCase, 
 DerivingStrategies, DerivingVia, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveGeneric
 #-}
module Control.Validation.Check(
    -- * Unvalidated values
    -- $unvalidated
    --
    Unvalidated(..), unvalidated,

    -- * Types for checks
    --

    -- ** Check results
    -- $checkResults
    -- 
    CheckResult(..),
    checkResult, failsWith, failsNoMsg,  passed, failed, checkResultToEither,

    -- ** The Check type
    -- $check
    --
    Check(..), Check',
    passOnRight, mapError, generalizeCheck,
    validateBy, validateBy',

    -- *** Constructing checks
    -- $constructingChecks
    --
    checking, checking',
    test,  (?~>),
    test', (?>),
    test_, (?~>>),
    test'_,(?>>),
    -- ** Helper for deriving Checkable
    -- $derivHelper
    foldWithCheck, traverseWithCheck,

    -- * Reexports
    hoist, contramap

) where

import           Data.Kind (Type)
import           GHC.Generics (Generic)

import           Control.Monad.Morph (MFunctor(..))
import           Data.Functor ((<&>))
import           Data.Functor.Contravariant (Contravariant(..), Op(..))
import           Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..))
import           Data.Functor.Identity (Identity(..))

import           Data.Foldable (fold)
import           Data.Monoid (Ap(..))


import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq(singleton)

----------------------------------------------------------------------------------
-- = 'Unvalidated'
-- $unvalidated
-- A newtype around unvalidated values so one cannot use the value until it is validated. 
-- You can create an 'Unvalidated' via 'unvalidated', but it is often more convient 
-- If for example you have a JSON api and want to validate incoming data, you can 
-- write (using `-XStandaloneDeriving, -XDerivingStrategies, -XDerivingVia`):
--
-- > import Data.Aeson(FromJSON)
-- > deriving via (a :: Type) instance (FromJSON a) => FromJSON (Unvalidated a)
newtype Unvalidated (a :: Type) =
    Unvalidated { unsafeValidate :: a }
    deriving (Eq, Ord, Show, Functor, Generic)

{-# INLINE unvalidated #-}
unvalidated :: a -> Unvalidated a
unvalidated = Unvalidated





----------------------------------------------------------------------------------
-- = Types for checks

-- == Check results
-- $checkResults
-- The result of (possibly many) checks. It is either valid or a sequence of 
-- all the errors that occurred during the check.
-- The semigroup operation is eager to collect all possible erros.

data CheckResult (e :: Type)
    = Passed
    | Failed (Seq e)
    deriving (Show, Eq, Generic, Functor)

instance Semigroup (CheckResult e) where
    Passed <> x = x
    Failed s1 <> Passed = Failed s1
    Failed s1 <> Failed s2 = Failed (s1 <> s2)

instance Monoid (CheckResult e) where
    mempty = Passed

failsWith :: e -> CheckResult e
failsWith = Failed . Seq.singleton

-- | Throwing an error without a message.
failsNoMsg :: CheckResult e
failsNoMsg = Failed mempty

-- | A fold for 'CheckResult'
checkResult :: a -> (Seq e -> a) -> CheckResult e -> a
checkResult x _ Passed = x
checkResult _ f (Failed e) = f e

passed, failed :: CheckResult e -> Bool
passed = checkResult True (const False)
failed = checkResult False (const True)


checkResultToEither :: a -- ^ default value
                    -> CheckResult e
                    -> Either (Seq e) a
checkResultToEither x = checkResult (Right x) Left




----------------------------------------------------------------------------------
-- ** The Check type
-- $check
-- The type of a (lifted) check. A 'Check' takes an unvalidated data and produces 
-- a 'CheckResult'. It may need an additional context `m`. If the context is trivial
-- (`m ≡ Identity`) helper types/functions are prefixed by a `'`.
-- A 'Check' is not a validation function, as it does not produce any values 
-- (to validated data using a 'Check' use 'validateBy'). The reason for this is that 
-- it gives 'Check' some useful instances, as it now is contravariant in `a` 
-- and not invariant in `a` like e.g. `a -> Either b a`
--
-- * Contravariant
-- 
-- > newtype Even = Even { getEven :: Int }
-- > checkEven :: Check' Text Even
-- > checkEven = (== 0) . (`mod` 2) . getEven ?> mappend "Number is not even: " . show
-- >
-- > newtype Odd = Odd { getOdd :: Int }
-- > checkOdd :: Check' Text Odd
-- > checkOdd = Even . (+1) . getOdd >$< checkEven
-- 
-- * Semigroup/Monoid: Allows for easy composition of checks
-- 
-- > newtype EvenAndOdd = EvenAndOdd { getEvenAndOdd :: Int }
-- > checkevenAndOdd :: Check' Text EvenAndOdd
-- > checkEvenAndOdd = contramap (Even . getEvenAndOdd) checkEven
-- >                   <> contramap (Odd . getEvenAndOdd) checkOdd
-- 
-- * MFunctor: Changing the effect
-- 
-- > import Data.List(isPrefixOf)
-- > newtype Url = Url { getUrl :: String }
-- >
-- > check404 :: Check () IO Url -- checks if the url returns 404
-- >
-- > checkHttps :: Check' () Identity Url
-- > checkHttps = ("https" `isPrefixOf`) ?>> ()
-- >
-- > checkUrl :: Check () IO Url
-- > checkUrl = check404 <> hoist generalize checkHttps
--
-- For more information see the README.

newtype Check (e :: Type) (m :: Type -> Type) (a :: Type)
    = Check { runCheck :: Unvalidated a -> m (CheckResult e) }
        deriving ( Monoid, Semigroup ) via (a -> Ap m (CheckResult e))
        deriving ( Contravariant, Divisible, Decidable) via (Op (Ap m (CheckResult e)))
withCheck :: ( (Unvalidated a -> m (CheckResult d))
             -> Unvalidated b -> n (CheckResult e))
             -> Check d m a -> Check e n b
withCheck f = Check . f . runCheck


-- | Validate 'Unvalidated' data using a check.
validateBy :: Functor m => Check e m a -> Unvalidated a -> m (Either (Seq e) a)
validateBy c u@(Unvalidated x) = fmap (checkResultToEither x) . runCheck c $ u

validateBy' :: Check' e a -> Unvalidated a -> Either (Seq e) a
validateBy' c = runIdentity . validateBy c

type Check' e = Check e Identity

instance MFunctor (Check e) where
    hoist f = withCheck (f .)


generalizeCheck :: Applicative m => Check' e a -> Check e m a
generalizeCheck = hoist (pure . runIdentity)

-- | 'passOnRight `ignoreWhen` `check` lets the argument pass when 
-- `ignoreWhen` returns `Nothing` and otherwise checks 
-- with `check`. It is a special case of 'choose' from 'Decidable'.
-- It gives an example for how 'Check's expand to other datatypes since they are
-- 'Divisible' and 'Decidable', see generalizing a check to lists:
-- >
-- > checkList :: Applicative m => Check e m a -> Check e m [a]
-- > checkList c = passOnRight (\case
-- >                             [] -> Right ()
-- >                             x:xs -> Left (x, xs))
-- >                           ( divide id c (checkList c))
passOnRight :: Applicative m => (a -> Either b ()) -> Check e m b -> Check e m a
passOnRight f c = choose f c mempty

-- | Mapping over the error type.
mapError :: Functor m => (e -> e') -> Check e m a -> Check e' m a
mapError f = withCheck (fmap (fmap f) .)




------------------------------------------------------------------------------------------------------
-- === Construction of 'Check's
-- $constructingChecks
-- Constructing a check from a predicate. Naming conventions: 
--
-- * Functions that work on trivial contexts are prefixed by an apostrophe `'`.
-- * Check constructors that discard the argument on error end with `_`.
-- * All infix operators start with `?` and end with `>` (So `?>` is the "normal" version).
-- * Additional >: discards its argument: `?>>`, `?~>>`.
-- * Tilde works with non-trivial contexts: `?~>`, `?~>>`.

checking :: (a -> m (CheckResult e)) -> Check e m a
checking = Check . (. unsafeValidate)

checking' :: (a -> CheckResult e) -> Check' e a
checking' = checking . (Identity .)


test', (?>) :: Applicative m => (a -> Bool) -> (a -> e) -> Check e m a
test' p onErr = Check $ \(Unvalidated x) -> pure $ if p x
    then Passed
    else failsWith (onErr x)
infix 7 `test'`
{-# INLINE (?>) #-}
(?>) = test'
infix 7 ?>


-- 
-- > test'_ p e = test' p onErr
-- >   where onErr = const e
{-# INLINE test'_ #-}
test'_,(?>>) :: Applicative m => (a -> Bool) -> e -> Check e m a
test'_ p = test' p . const
infix 7 `test'_`
{-# INLINE (?>>) #-}
(?>>) = test'_
infix 7 ?>>

test, (?~>) :: Functor m => (a -> m Bool) -> (a -> e) -> Check e m a
test p onErr = Check $ \(Unvalidated x) -> p x <&> \case
    True  -> Passed
    False -> failsWith . onErr $ x
infix 7 `test`
{-# INLINE (?~>) #-}
(?~>) = test
infix 7 ?~>

-- > test_ p e = test p onErr
-- >   where onErr = const e
{-# INLINE test_ #-}
test_, (?~>>) :: Monad m => (a -> m Bool) -> e -> Check e m a
test_ p = test p . const
infix 7 `test_`
{-# INLINE (?~>>) #-}
(?~>>) = test_
infix 7 ?~>>


-- | Lifting checks
foldWithCheck :: (Foldable f, Applicative m) => Check e m a -> Check e m (f a)
foldWithCheck c = checking $ getAp . foldMap (Ap . runCheck c . unvalidated)

traverseWithCheck :: (Traversable t, Applicative m) => Check e m a -> Check e m (t a)
traverseWithCheck c = checking $ fmap fold . traverse (runCheck c . unvalidated)