{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-|
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 an introduction see the [README](https://gitlab.com/Birkmann/validation-check/-/blob/master/README.md).
-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE PolyKinds                  #-}

{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeOperators              #-}
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', pass,
    passOnRight, mapError, generalizeCheck,
    validateBy, validateBy',

    -- *** Constructing checks
        -- $constructingChecks
    checking, checking',
    -- $constructionByPredicate
    test,  (?~>),
    test', (?>),
    test_, (?~>>),
    test'_,(?>>),
    -- ** Lifting Checks
    -- $derivHelper
    foldWithCheck, traverseWithCheck,

    -- ** For ADTs
    -- $adts
    joinMultiCheck, mapErrorsWithInfo, constructorCheck,

    -- * Reexports

    -- ** General
    hoist, contramap,

    -- ** SOP
    NP(..), DatatypeName, ConstructorName, FieldName
)

where

import           Data.Kind                            (Type)
import Control.Validation.Internal.SOP(errMsgPOP)
import           GHC.Generics                          as GHC(Generic)
import Generics.SOP as SOP(POP(..), unPOP, mapIK, hliftA2, unK, hcfoldMap, NP(..), Generic(..), Top, HasDatatypeInfo(..), DatatypeName, ConstructorName, FieldName, NS(..), SListI, hcexpand, hpure)
import Data.Proxy(Proxy(..))
import           Control.Monad.Morph                  (MFunctor (..))
import           Data.Functor                         ((<&>))
import           Data.Functor.Contravariant           (Contravariant (..),
                                                       Op (..))
import           Data.Functor.Contravariant.Divisible (Decidable (..),
                                                       Divisible (..))
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'
--
-- __/WARNING/__ The 'Unvalidated' data construcotr should __/NOT/__ be used in real code and is exported solely to be used in @-XDeriving@-clauses
--
-- , but it is often more convient to write an orphan instance:
-- 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) =
    MkUnvalidated { unsafeValidate :: a }
    deriving (Eq, Ord, Show, Functor, GHC.Generic)
    deriving (Applicative, Monad) via Identity
{-# WARNING MkUnvalidated "Use 'unvalidated'. The data constructor 'Unvalidated' is not to be used in code and is only exported for use in deriving clauses" #-}

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





----------------------------------------------------------------------------------
-- = 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, GHC.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 postfixed by an apostrophe `'`.
-- 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)))

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

withCheck :: ( (Unvalidated a -> m (CheckResult d))
             -> Unvalidated b -> n (CheckResult e))
             -> Check d m a -> Check e n b
withCheck f = Check . f . runCheck

-- | The trivial 'Check' that always succeeds.
pass :: Applicative m => Check e m a
pass = mempty

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

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

-- | A 'Check' with a trivial context
type Check' e = Check e Identity

-- | Generalize a 'Check' without context to any 'Check' with an applicative context
generalizeCheck :: Applicative m => Check' e a -> Check e m a
generalizeCheck = hoist (pure . runIdentity)

-- | 'passOnRight `ignoreWhen` `check` lets the argument pass when
-- `ignoreWhen` returns `Right ()` 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
-- The general way to construct a 'Check': Take the data to be checked and return a 'CheckResult'.
--
-- ==== Construction by predicates
-- $constructionByPredicate
-- Constructing a check from a predicate (if a prediceate returns 'True', the check passes) and a function constructing the error from the input. Naming conventions:
--
-- * Functions that work on trivial contexts are postfixed 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 $ \(MkUnvalidated 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 $ \(MkUnvalidated 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 ?~>>


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

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

-- == Lift 'Check's to ADTs
-- $adts
-- | A "Multi"-'Check' for an ADT, one 'Check e m' for each field of each constructor, organized in Lists (see examples for construction)
type MultiCheck e m a = NP (NP (Check e m)) (Code a)


-- | Combine all 'Check's from a 'MultiCheck' into a single 'Check' for the datatype 'a' (given it has a 'Generic' instance).
joinMultiCheck :: forall a m e. (Applicative m, SOP.Generic a) => MultiCheck e m a -> Check e m a
joinMultiCheck checks = checking $ getAp
                           . hcfoldMap (Proxy @Top) (Ap . unK)
                           . hliftA2 (\c -> mapIK $ runCheck c . unvalidated)
                                     (POP $ checks)
                           . from



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

-- | Make a 'Check' for that only checks a single constructor by suppling a list containing a 'Check' for each field
constructorCheck :: forall a m e xs. (Applicative m, SOP.Generic a)
                                              => (NP (Check e m) xs -> NS (NP (Check e m)) (Code a)) -- ^ The function deciding the constructor, 'Z' for the zeroth, 'S . Z' for the first, etc.
                                              -> NP (Check e m) xs -- ^ Product of 'Checkes', one for each constructor
                                              -> Check e m a
constructorCheck f ps  = joinMultiCheck . hcexpand (Proxy @SListI) (hpure  mempty) . f $ ps