Unpacked.hs

--------------------------------------------------------------------------------

-- Copyright © 2018 chessai

-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
-- 
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
-- 
--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.
-- 
--     * Neither the name of chessai nor the names of other
--       contributors may be used to endorse or promote products derived
--       from this software without specific prior written permission.
-- 
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

--------------------------------------------------------------------------------

{-# OPTIONS_GHC -Wall -O2 #-}

--------------------------------------------------------------------------------

{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE PatternSynonyms    #-}
{-# LANGUAGE UnboxedSums        #-}
{-# LANGUAGE UnboxedTuples      #-}

--------------------------------------------------------------------------------

{-|
-}

module Data.Validation.Unpacked
  ( -- * Data type
    Validation(Validation, Failure, Success)
    -- * Construction
  , failure
  , success
  , validate
  , fromEither
  , liftError
    -- * Functions on validations
  , validation
  , toEither
  , orElse
  , valueOr
  , ensure
  , codiagonal
  , bindValidation
    -- * Conversion
  , fromBaseValidation
  , toBaseValidation
  ) where

--------------------------------------------------------------------------------

import Prelude
  ()

import           Control.Applicative  (Applicative((<*>), pure))
import           Control.DeepSeq      (NFData(rnf))
import           Control.Monad        (return)

import           Data.Bifoldable      (Bifoldable(bifoldr))
import           Data.Bifunctor       (Bifunctor(bimap))
import           Data.Bitraversable   (Bitraversable(bitraverse))

import           Data.Bool            (Bool(False))
import           Data.Either.Unpacked (Either(Left, Right), either)
import           Data.Eq              (Eq((==)))
import           Data.Foldable        (Foldable(foldr))

import           Data.Function        ((.), id)
import           Data.Functor         (Functor(fmap), (<$>))

import           Data.Monoid         (Monoid(mempty,mappend))
import           Data.Ord            (Ord(compare, (>=)), Ordering(GT, LT))
import           Data.Semigroup      (Semigroup((<>)))
import           Data.Traversable    (Traversable(traverse))

import qualified Data.Validation     as BaseValidation

import           GHC.Read            (Read(readPrec, readList), expectP)
import           GHC.Show            (Show(showsPrec, showList), showString, showParen, showList__)

import           Text.Read           (parens, Lexeme(Ident), (+++), readListPrec, readListDefault, readListPrecDefault)
import           Text.ParserCombinators.ReadPrec
  (prec, step)

--------------------------------------------------------------------------------

-- | A @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However,
-- the 'Applicative' instance for @Validation@ /accumulates/ errors using a 'Semigroup' on @err@.
-- In contrast, the @Applicative@ for @Either@ returns only the first error.
--
-- A consequence of this is that @Validation@ has no 'Control.Monad.Monad' instance. This is because
-- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the
-- @Applicative@'s 'Control.Applicative.<*>'
--
-- An example of typical usage can be found <https://github.com/qfpl/validation/blob/master/examples/src/Email.hs here>.
--
data Validation err a = Validation (# err | a #)

pattern Failure :: err -> Validation err a
pattern Failure err = Validation (# err | #)

pattern Success :: a -> Validation err a
pattern Success a = Validation (# | a #)

{-# COMPLETE Failure, Success #-}

-- | This is the same as 'Failure'.
failure :: err -> Validation err a
{-# INLINE failure #-}
failure err = Validation (# err | #)

-- | This is the same as 'Success'.
success :: a -> Validation err a
{-# INLINE success #-}
success a = Validation (# | a #)

appValidation :: (err -> err -> err)
              -> Validation err a
              -> Validation err a
              -> Validation err a
{-# INLINE appValidation #-}
appValidation m (Failure e1) (Failure e2) = Failure (e1 `m` e2)
appValidation _ (Failure  _) (Success a2) = Success a2
appValidation _ (Success a1) (Failure  _) = Success a1
appValidation _ (Success a1) (Success  _) = Success a1

-- | 'validate's the @a@ with the given predicate, returning @e@ if the predicate does not hold.
validate :: err -> (a -> Bool) -> a -> Validation err a
{-# INLINE validate #-}
validate e p a = if p a
                 then Success a
                 else Failure e

-- | Case analysis on 'Validation'.
validation :: (e -> c) -> (a -> c) -> Validation e a -> c
{-# INLINE validation #-}
validation ec _ (Failure e) = ec e
validation _ ac (Success a) = ac a

-- | 'liftError' is useful for converting an 'Either' to an 'Validation'
-- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'.
liftError :: (b -> e) -> Either b a -> Validation e a
{-# INLINE liftError #-}
liftError f = either (Failure . f) Success

-- | Converts from 'Either' to 'Validation'.
fromEither :: Either e a -> Validation e a
{-# INLINE fromEither #-}
fromEither = liftError id

-- | Converts from 'Validation' to 'Either'.
toEither :: Validation e a -> Either e a
{-# INLINE toEither #-}
toEither = validation Left Right

-- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@.
orElse :: Validation e a -> a -> a
{-# INLINE orElse #-}
orElse v a = validation (\_ -> a) id v

-- | Return the @a@ or run the given function over the @e@.
valueOr :: (e -> a) -> Validation e a -> a
{-# INLINE valueOr #-}
valueOr ea (Failure e) = ea e
valueOr _  (Success a) = a

-- | 'codiagonal' gets the value out of either side.
codiagonal :: Validation a a -> a
{-# INLINE codiagonal #-}
codiagonal = valueOr id

-- | 'ensure' leaves the validation unchanged when the predicate holds, or
-- fails with @e@ otherwise.
ensure :: e -> (a -> Bool) -> Validation e a -> Validation e a
{-# INLINE ensure #-}
ensure _ _ (Failure x) = Failure x
ensure e p (Success a) = validate e p a

-- | @bindValidation@ binds through an Validation, which is useful for
-- composing Validations sequentially. Note that despite having a bind
-- function of the correct type, Validation is not a monad.
-- The reason is, this bind does not accumulate errors, so it does not
-- agree with the Applicative instance.
--
-- There is nothing wrong with using this function, it just does not make a
-- valid @Monad@ instance.
bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b
bindValidation (Failure e) _ = Failure e
bindValidation (Success a) f = f a

-- | Convert validation's 'BaseValidation.Validation' to a 'Validation'.
fromBaseValidation :: BaseValidation.Validation a b -> Validation a b
fromBaseValidation (BaseValidation.Failure  a) = failure a
fromBaseValidation (BaseValidation.Success  b) = success b

-- | Convert a 'Validation' to validation's 'BaseValidation.Validation'.
toBaseValidation :: Validation a b -> BaseValidation.Validation a b
toBaseValidation (Failure a) = BaseValidation.Failure a
toBaseValidation (Success b) = BaseValidation.Success b

--------------------------------------------------------------------------------

-- this is what happens when you can't derive things
instance (Eq a, Eq b) => Eq (Validation a b) where
  Failure  a == Failure  b = a == b
  Success  a == Success  b = a == b
  _          == _          = False
  {-# INLINE (==) #-}

-- this is what happens when you can't derive things
instance (Ord a, Ord b) => Ord (Validation a b) where
  compare x y
    = case x of
        Failure a -> case y of
          Failure b -> compare a b
          _      -> LT
        Success a -> case y of
          Success b -> compare a b
          _       -> GT
  {-# INLINE compare #-}

-- this is what happens when you can't derive things
instance (Read a, Read b) => Read (Validation a b) where
  readPrec
    = parens (prec 10
          (do expectP (Ident "Failure")
              a <- step readPrec
              return (Failure a))
          +++
            prec
              10
              (do expectP (Ident "Success")
                  b <- step readPrec
                  return (Success b)))
  readList = readListDefault
  readListPrec = readListPrecDefault

-- this is what happens when you can't derive things
instance (Show b, Show a) => Show (Validation a b) where
  showsPrec i (Failure a)
    = showParen
        (i >= 11)
        ((.)
           (showString "Failure ") (showsPrec 11 a))
  showsPrec i (Success b)
    = showParen
        (i >= 11)
        ((.)
           (showString "Success ") (showsPrec 11 b))
  showList = showList__ (showsPrec 0)

instance Functor (Validation err) where
  fmap _ (Failure e) = Failure e
  fmap f (Success a) = Success (f a)
  {-# INLINE fmap #-}

instance Semigroup err => Applicative (Validation err) where
  pure = Success
  {-# INLINE pure #-} 
  Failure e1 <*> Failure e2 = Failure (e1 <> e2)
  Failure e1 <*> Success _  = Failure e1
  Success _  <*> Failure e2 = Failure e2
  Success f  <*> Success a  = Success (f a)
  {-# INLINE (<*>) #-}

instance Foldable (Validation err) where
  foldr f x (Success a) = f a x
  foldr _ x (Failure _) = x
  {-# INLINE foldr #-}

instance Traversable (Validation err) where
  traverse f (Success a) = Success <$> f a
  traverse _ (Failure e) = pure (Failure e)
  {-# INLINE traverse #-}

instance Bifunctor Validation where
  bimap f _ (Failure e) = Failure (f e)
  bimap _ g (Success a) = Success (g a)
  {-# INLINE bimap #-}

instance Bifoldable Validation where
  bifoldr _ g x (Success a) = g a x
  bifoldr f _ x (Failure e) = f e x
  {-# INLINE bifoldr #-}

instance Bitraversable Validation where
  bitraverse _ g (Success a) = Success <$> g a
  bitraverse f _ (Failure e) = Failure <$> f e
  {-# INLINE bitraverse #-}

instance Semigroup e => Semigroup (Validation e a) where
  (<>) = appValidation (<>)
  {-# INLINE (<>) #-}

instance Monoid e => Monoid (Validation e a) where
  mappend = appValidation mappend
  {-# INLINE mappend #-} 
  mempty  = Failure mempty
  {-# INLINE mempty #-}

instance (NFData e, NFData a) => NFData (Validation e a) where
  rnf (Failure e) = rnf e
  rnf (Success a) = rnf a
  {-# INLINE rnf #-}