{-
  Copyright © 2023 Josep Bigorra

  This file is part of Keuringsdienst.
  Keuringsdienst is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation,
    either version 3 of the License, or (at your option) any later version.

  Keuringsdienst is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
    without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

  See the GNU General Public License for more details.
  You should have received a copy of the GNU General Public License along with Keuringsdienst.
  If not, see <https://www.gnu.org/licenses/>.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Keuringsdienst
  ( -- * Core types
    ValidationResult,
    ValidationRule (..),
    Validation (..),

    -- * Operators
    keuren,
    misschienKeuren,
    validate,
    maybeValidate,
    ofDitOfDat,
    orThisOrThat,
    (*||*),
    (|??|),
    (|?|),
  )
where

import Data.Aeson hiding (Success)
import Data.Text as T
import GHC.Generics

-- | Data type that represents the error messages. Currently is set to a simple Text,
--  futurely this could be expanded to contain more metadata.
type ErrMsg = Text

-- | Core data type representing the outcome of a validation, which can be a success,
--  or a failure with more information about the failure.
data Validation err
  = Success
  | Failure err
  deriving (Validation err -> Validation err -> Bool
(Validation err -> Validation err -> Bool)
-> (Validation err -> Validation err -> Bool)
-> Eq (Validation err)
forall err. Eq err => Validation err -> Validation err -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall err. Eq err => Validation err -> Validation err -> Bool
== :: Validation err -> Validation err -> Bool
$c/= :: forall err. Eq err => Validation err -> Validation err -> Bool
/= :: Validation err -> Validation err -> Bool
Eq, Int -> Validation err -> ShowS
[Validation err] -> ShowS
Validation err -> String
(Int -> Validation err -> ShowS)
-> (Validation err -> String)
-> ([Validation err] -> ShowS)
-> Show (Validation err)
forall err. Show err => Int -> Validation err -> ShowS
forall err. Show err => [Validation err] -> ShowS
forall err. Show err => Validation err -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall err. Show err => Int -> Validation err -> ShowS
showsPrec :: Int -> Validation err -> ShowS
$cshow :: forall err. Show err => Validation err -> String
show :: Validation err -> String
$cshowList :: forall err. Show err => [Validation err] -> ShowS
showList :: [Validation err] -> ShowS
Show, (forall x. Validation err -> Rep (Validation err) x)
-> (forall x. Rep (Validation err) x -> Validation err)
-> Generic (Validation err)
forall x. Rep (Validation err) x -> Validation err
forall x. Validation err -> Rep (Validation err) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall err x. Rep (Validation err) x -> Validation err
forall err x. Validation err -> Rep (Validation err) x
$cfrom :: forall err x. Validation err -> Rep (Validation err) x
from :: forall x. Validation err -> Rep (Validation err) x
$cto :: forall err x. Rep (Validation err) x -> Validation err
to :: forall x. Rep (Validation err) x -> Validation err
Generic, Maybe (Validation err)
Value -> Parser [Validation err]
Value -> Parser (Validation err)
(Value -> Parser (Validation err))
-> (Value -> Parser [Validation err])
-> Maybe (Validation err)
-> FromJSON (Validation err)
forall err. FromJSON err => Maybe (Validation err)
forall err. FromJSON err => Value -> Parser [Validation err]
forall err. FromJSON err => Value -> Parser (Validation err)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall err. FromJSON err => Value -> Parser (Validation err)
parseJSON :: Value -> Parser (Validation err)
$cparseJSONList :: forall err. FromJSON err => Value -> Parser [Validation err]
parseJSONList :: Value -> Parser [Validation err]
$comittedField :: forall err. FromJSON err => Maybe (Validation err)
omittedField :: Maybe (Validation err)
FromJSON, [Validation err] -> Value
[Validation err] -> Encoding
Validation err -> Bool
Validation err -> Value
Validation err -> Encoding
(Validation err -> Value)
-> (Validation err -> Encoding)
-> ([Validation err] -> Value)
-> ([Validation err] -> Encoding)
-> (Validation err -> Bool)
-> ToJSON (Validation err)
forall err. ToJSON err => [Validation err] -> Value
forall err. ToJSON err => [Validation err] -> Encoding
forall err. ToJSON err => Validation err -> Bool
forall err. ToJSON err => Validation err -> Value
forall err. ToJSON err => Validation err -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall err. ToJSON err => Validation err -> Value
toJSON :: Validation err -> Value
$ctoEncoding :: forall err. ToJSON err => Validation err -> Encoding
toEncoding :: Validation err -> Encoding
$ctoJSONList :: forall err. ToJSON err => [Validation err] -> Value
toJSONList :: [Validation err] -> Value
$ctoEncodingList :: forall err. ToJSON err => [Validation err] -> Encoding
toEncodingList :: [Validation err] -> Encoding
$comitField :: forall err. ToJSON err => Validation err -> Bool
omitField :: Validation err -> Bool
ToJSON)

-- | ValidationResult is the data type of choice for now, since we have chosen to implement
-- the library in a way that it will return a [Text] as context for validation failures.
type ValidationResult = Validation [ErrMsg]

instance Semigroup ValidationResult where
  <> :: ValidationResult -> ValidationResult -> ValidationResult
(<>) ValidationResult
a ValidationResult
b = case ValidationResult
a of
    ValidationResult
Success -> case ValidationResult
b of
      ValidationResult
Success -> ValidationResult
forall err. Validation err
Success
      Failure [ErrMsg]
errorsB -> [ErrMsg] -> ValidationResult
forall err. err -> Validation err
Failure [ErrMsg]
errorsB
    Failure [ErrMsg]
errorsA -> case ValidationResult
b of
      ValidationResult
Success -> [ErrMsg] -> ValidationResult
forall err. err -> Validation err
Failure [ErrMsg]
errorsA
      Failure [ErrMsg]
errorsB -> [ErrMsg] -> ValidationResult
forall err. err -> Validation err
Failure ([ErrMsg]
errorsA [ErrMsg] -> [ErrMsg] -> [ErrMsg]
forall a. Semigroup a => a -> a -> a
<> [ErrMsg]
errorsB)

instance Monoid ValidationResult where
  mempty :: ValidationResult
mempty = ValidationResult
forall err. Validation err
Success

-- | Data type representing a composable validation rule to be applied on a certain data.
newtype ValidationRule a = ValidationRule
  { forall a. ValidationRule a -> a -> ValidationResult
performValidation :: a -> ValidationResult
  }

instance Semigroup (ValidationRule x) where
  <> :: ValidationRule x -> ValidationRule x -> ValidationRule x
(<>) ValidationRule x
a ValidationRule x
b = do
    ValidationRule
      { performValidation :: x -> ValidationResult
performValidation = \x
value -> ValidationRule x -> x -> ValidationResult
forall a. ValidationRule a -> a -> ValidationResult
performValidation ValidationRule x
a x
value ValidationResult -> ValidationResult -> ValidationResult
forall a. Semigroup a => a -> a -> a
<> ValidationRule x -> x -> ValidationResult
forall a. ValidationRule a -> a -> ValidationResult
performValidation ValidationRule x
b x
value
      }

instance Monoid (ValidationRule a) where
  mempty :: ValidationRule a
mempty = ValidationRule {performValidation :: a -> ValidationResult
performValidation = ValidationResult -> a -> ValidationResult
forall a b. a -> b -> a
const ValidationResult
forall err. Validation err
Success}

-- | This function applies a validation rule to a value. Stands for validate/judge in Dutch.
keuren :: a -> ValidationRule a -> ValidationResult
keuren :: forall a. a -> ValidationRule a -> ValidationResult
keuren a
x ValidationRule a
rule = ValidationRule a -> a -> ValidationResult
forall a. ValidationRule a -> a -> ValidationResult
performValidation ValidationRule a
rule a
x

infixl 8 |?|

-- | keuren operator
(|?|) :: a -> ValidationRule a -> ValidationResult
|?| :: forall a. a -> ValidationRule a -> ValidationResult
(|?|) = a -> ValidationRule a -> ValidationResult
forall a. a -> ValidationRule a -> ValidationResult
keuren

-- | Alias to the keuren operator
validate :: a -> ValidationRule a -> ValidationResult
validate :: forall a. a -> ValidationRule a -> ValidationResult
validate = a -> ValidationRule a -> ValidationResult
forall a. a -> ValidationRule a -> ValidationResult
keuren

-- | This function applies a validation rule to a value when it is a Just and
-- defaults to a Success in case of a Nothing. Stands for maybe validate/judge in Dutch.
misschienKeuren :: Maybe a -> ValidationRule a -> ValidationResult
misschienKeuren :: forall a. Maybe a -> ValidationRule a -> ValidationResult
misschienKeuren Maybe a
x ValidationRule a
rule = ValidationResult
-> (a -> ValidationResult) -> Maybe a -> ValidationResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ValidationResult
forall err. Validation err
Success (ValidationRule a -> a -> ValidationResult
forall a. ValidationRule a -> a -> ValidationResult
performValidation ValidationRule a
rule) Maybe a
x

infixl 8 |??|

-- | misschienKeuren operator
(|??|) :: Maybe a -> ValidationRule a -> ValidationResult
|??| :: forall a. Maybe a -> ValidationRule a -> ValidationResult
(|??|) = Maybe a -> ValidationRule a -> ValidationResult
forall a. Maybe a -> ValidationRule a -> ValidationResult
misschienKeuren

-- | Alias to the misschienKeuren operator
maybeValidate :: Maybe a -> ValidationRule a -> ValidationResult
maybeValidate :: forall a. Maybe a -> ValidationRule a -> ValidationResult
maybeValidate = Maybe a -> ValidationRule a -> ValidationResult
forall a. Maybe a -> ValidationRule a -> ValidationResult
misschienKeuren

-- | If one of the validations has a successful result, then the validation is a success.
-- Stands for or this or that in Dutch.
ofDitOfDat :: ValidationRule a -> ValidationRule a -> ValidationRule a
ofDitOfDat :: forall x. ValidationRule x -> ValidationRule x -> ValidationRule x
ofDitOfDat ValidationRule a
rule1 ValidationRule a
rule2 = (a -> ValidationResult) -> ValidationRule a
forall a. (a -> ValidationResult) -> ValidationRule a
ValidationRule ((a -> ValidationResult) -> ValidationRule a)
-> (a -> ValidationResult) -> ValidationRule a
forall a b. (a -> b) -> a -> b
$ \a
actual ->
  case (ValidationRule a -> a -> ValidationResult
forall a. ValidationRule a -> a -> ValidationResult
performValidation ValidationRule a
rule1 a
actual, ValidationRule a -> a -> ValidationResult
forall a. ValidationRule a -> a -> ValidationResult
performValidation ValidationRule a
rule2 a
actual) of
    (Failure [ErrMsg]
e1, Failure [ErrMsg]
e2) -> [ErrMsg] -> ValidationResult
forall err. err -> Validation err
Failure ([ErrMsg]
e1 [ErrMsg] -> [ErrMsg] -> [ErrMsg]
forall a. Semigroup a => a -> a -> a
<> [ErrMsg]
e2)
    (ValidationResult
Success, ValidationResult
_) -> ValidationResult
forall err. Validation err
Success
    (ValidationResult
_, ValidationResult
Success) -> ValidationResult
forall err. Validation err
Success

infixl 6 *||*

-- | ofDitOfDat operator
(*||*) :: ValidationRule a -> ValidationRule a -> ValidationRule a
*||* :: forall x. ValidationRule x -> ValidationRule x -> ValidationRule x
(*||*) = ValidationRule a -> ValidationRule a -> ValidationRule a
forall x. ValidationRule x -> ValidationRule x -> ValidationRule x
ofDitOfDat

-- | Alias to the ofDitOfDat operator
orThisOrThat :: ValidationRule a -> ValidationRule a -> ValidationRule a
orThisOrThat :: forall x. ValidationRule x -> ValidationRule x -> ValidationRule x
orThisOrThat = ValidationRule a -> ValidationRule a -> ValidationRule a
forall x. ValidationRule x -> ValidationRule x -> ValidationRule x
ofDitOfDat