diff --git a/Data/Validation.hs b/Data/Validation.hs new file mode 100644 --- /dev/null +++ b/Data/Validation.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Data types similar to @Data.Either@ that are explicit about failure and success. +module Data.Validation +( + AccValidation +, Validation +, ValidationT +, Validate(..) +, FoldValidate(..) +, runValidationT +, fromFailure +, fromSuccess +, getFailure +, getSuccess +, getFailureOr +, getSuccessOr +) where + +import Control.Functor.Pointed +import Control.Applicative +import Data.Semigroup +import Data.Maybe +import Data.Typeable +import Data.Data + +-- | A value of the type @err@ or @a@, however, the @Applicative@ instance +-- accumulates values. This is witnessed by the @Semigroup@ context on the instance. +-- /Note that there is no @Monad@ such that @ap = (<*>)./ +-- +-- * @success (+1) <*> success 7 == AccSuccess 8@ +-- +-- * @failure ["f1"] <*> success 7 == AccFailure ["f1"]@ +-- +-- * @success (+1) <*> failure ["f2"] == AccFailure ["f2"]@ +-- +-- * @failure ["f1"] <*> failure ["f2"] == AccFailure ["f1","f2"]@ +data AccValidation err a = + AccFailure err + | AccSuccess a + deriving (Eq, Ord, Show, Data, Typeable) + +instance Functor (AccValidation err) where + fmap _ (AccFailure e) = AccFailure e + fmap f (AccSuccess a) = AccSuccess (f a) + +instance Pointed (AccValidation err) where + point = AccSuccess + +instance Semigroup err => Applicative (AccValidation err) where + pure = point + AccFailure e1 <*> AccFailure e2 = AccFailure (e1 .++. e2) + AccFailure e1 <*> AccSuccess _ = AccFailure e1 + AccSuccess _ <*> AccFailure e2 = AccFailure e2 + AccSuccess f <*> AccSuccess a = AccSuccess (f a) + +-- | A value of the type @err@ or @a@ and isomorphic to @Data.Either@. +data Validation err a = + Failure err + | Success a + deriving (Eq, Ord, Show, Data, Typeable) + +instance Functor (Validation err) where + fmap _ (Failure e) = Failure e + fmap f (Success a) = Success (f a) + +instance Pointed (Validation err) where + point = Success + +instance Applicative (Validation err) where + pure = point + Failure e1 <*> Failure _ = Failure e1 + Failure e1 <*> Success _ = Failure e1 + Success _ <*> Failure e2 = Failure e2 + Success f <*> Success a = Success (f a) + +instance Monad (Validation err) where + return = point + Failure e >>= _ = Failure e + Success a >>= f = f a + +-- | The transformer version of @Validation@. +data ValidationT m err a = + ValidationT { + runValidationT :: m (Validation err a) + } + +instance Functor m => Functor (ValidationT m err) where + fmap f (ValidationT k) = + ValidationT (fmap (fmap f) k) + +instance Pointed m => Pointed (ValidationT m err) where + point = ValidationT . point . point + +instance Applicative m => Applicative (ValidationT m err) where + pure = ValidationT . pure . point + ValidationT f <*> ValidationT a = ValidationT (liftA2 (<*>) f a) + +instance Monad m => Monad (ValidationT m err) where + return = ValidationT . return . point + ValidationT v >>= f = ValidationT (v >>= \w -> case w + of Failure e -> return (Failure e) + Success a -> runValidationT (f a)) + +-- | Construction for validation values. +class Validate v where + -- | Construct a success validation value. + success :: + a + -> v err a + -- | Construct a failure validation value. + failure :: + err + -> v err a + +-- | Reduction for validation values. +class FoldValidate v where + -- | Reduce a validation value /(catamorphism)/. + foldValidate :: + (err -> x) -- ^ The function to run if a failure value. + -> (a -> x) -- ^ The function to run if a success value. + -> v err a -- ^ The validation value. + -> x + +instance Validate AccValidation where + success = + point + failure = + AccFailure + +instance FoldValidate AccValidation where + foldValidate f _ (AccFailure err) = + f err + foldValidate _ g (AccSuccess a) = + g a + +instance Validate Validation where + success = + point + failure = + Failure + +instance FoldValidate Validation where + foldValidate f _ (Failure err) = + f err + foldValidate _ g (Success a) = + g a + +instance Pointed m => Validate (ValidationT m) where + success = + ValidationT . point . success + failure = + ValidationT . point . failure + +-- | Returns the failure value or runs the given function on the success value to get a failure value. +fromFailure :: + FoldValidate v => + (a -> err) -- ^ The function to run on the success value. + -> v err a + -> err +fromFailure = + foldValidate id + +-- | Returns the success value or runs the given function on the failure value to get a success value. +fromSuccess :: + FoldValidate v => + (err -> a) -- ^ The function to run on the failure value. + -> v err a + -> a +fromSuccess = + flip foldValidate id + +-- | Returns the possible failure value if there is one. +getFailure :: + FoldValidate v => + v err a + -> Maybe err +getFailure = + foldValidate Just (const Nothing) + +-- | Returns the possible success value if there is one. +getSuccess :: + FoldValidate v => + v err a + -> Maybe a +getSuccess = + foldValidate (const Nothing) Just + +-- | Returns the failure value if there is one, otherwise returns the given default. +getFailureOr :: + FoldValidate v => + err -- ^ The default to return if there is no failure value to return. + -> v err a + -> err +getFailureOr e = + fromMaybe e . getFailure + +-- | Returns the success value if there is one, otherwise returns the given default. +getSuccessOr :: + FoldValidate v => + a -- ^ The default to return if there is no success value to return. + -> v err a + -> a +getSuccessOr a = + fromMaybe a . getSuccess + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2010 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/Validation.cabal b/Validation.cabal new file mode 100644 --- /dev/null +++ b/Validation.cabal @@ -0,0 +1,32 @@ +Name: Validation +Version: 0.0.1 +License: BSD3 +License-File: LICENSE +Author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>, Nick Partridge +Maintainer: Tony Morris, Nick Partridge +Synopsis: A data-type like Either but with an accumulating Applicative +Category: Data +Description: A data-type like Either but with an accumulating Applicative +Cabal-version: >= 1.2 +Build-Type: Simple + +Flag small_base + Description: Choose the new, split-up base package. + +Library + Build-Depends: + base < 5 && >= 4 + , Semigroup + , category-extras + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + + GHC-Options: + -Wall + + Exposed-Modules: + Data.Validation +