diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Validation/Unpacked.hs b/src/Data/Validation/Unpacked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Validation/Unpacked.hs @@ -0,0 +1,325 @@ +-------------------------------------------------------------------------------- + +-- 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 . +-- +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 #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE KindSignatures #-} + +module Main (main) where + +import Control.Applicative +import Control.Monad (liftM) +import Data.Functor.Classes +import Data.Validation.Unpacked +import Data.Proxy (Proxy(..)) +import Data.Semigroup (Semigroup((<>))) +import Test.QuickCheck.Classes +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +main :: IO () +main = lawsCheckMany myClassTests + +myClassTests :: [(String, [Laws])] +myClassTests = + [ ("Ground types", myLaws validationProxy) +-- , ("Higher-kinded types", myLaws1 validationProxy1) + ] + +myLaws + :: (Arbitrary a, Eq a, Ord a, Show a, Read a) + => Proxy a -> [Laws] +myLaws p = + [ eqLaws p + , ordLaws p + , showReadLaws p + ] + +--myLaws1 +-- :: (Arbitrary1 a, Monad a, Functor a, Applicative a, Foldable a, Traversable a, Eq1 a, Show1 a) +-- => Proxy a -> [Laws] +--myLaws1 p = +-- [ monadLaws p +-- , functorLaws p +-- , applicativeLaws p +-- , foldableLaws p +-- , traversableLaws p +-- ] + +validationProxy2 :: Proxy Validation +validationProxy2 = Proxy + +validationProxy1 :: Proxy (Validation Int) +validationProxy1 = Proxy + +validationProxy :: Proxy (Validation Int Int) +validationProxy = Proxy + +instance Semigroup Int where + (<>) = (+) + +instance Monoid Int where + mempty = 0 + mappend = (+) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Validation a b) where + arbitrary = arbitrary2 + shrink = shrink2 + +instance Arbitrary2 Validation where + liftArbitrary2 arbA arbB = oneof [liftM Failure arbA, liftM Success arbB] + + liftShrink2 shrA _ (Failure x) = [ Failure x' | x' <- shrA x ] + liftShrink2 _ shrB (Success y) = [ Success y' | y' <- shrB y ] + +instance Arbitrary a => Arbitrary1 (Validation a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink diff --git a/unpacked-validation.cabal b/unpacked-validation.cabal new file mode 100644 --- /dev/null +++ b/unpacked-validation.cabal @@ -0,0 +1,57 @@ +-------------------------------------------------------------------------------- + +name: unpacked-validation +version: 0.1.0.0 +synopsis: An unpacked validation data type +description: + The 'Validation' type and associated operations. + . + This library is intended to be a drop-in replacement for /Data.Valiation/. To shave off pointer chasing, it uses -XUnboxedSums to represent the 'Validation' type as two machine words that are contiguous in memory, without loss of expressiveness that 'Validation' provides. + . + This library provides pattern synonyms Failure and Success, which allow users to pattern match on an Unpacked Validation in a familiar way. + . + Functions are also provided for converting an Unpacked Validation to the validation library's These, and vice versa. + . + This library is in alpha, and the internals are likely to change. +homepage: https://github.com/chessai/unpacked-validation +license: BSD3 +license-file: LICENSE +author: chessai +maintainer: chessai1996@gmail.com +copyright: Copyright © 2018 chessai +category: Development +build-type: Simple +cabal-version: >=1.10 + +-------------------------------------------------------------------------------- + +library + hs-source-dirs: src + exposed-modules: Data.Validation.Unpacked + build-depends: base >= 4.10 && < 5 + , deepseq + , ghc-prim + , unpacked-either + , validation + default-language: Haskell2010 + +------------------------------------------------------------------------------- + +test-suite unpacked-validation-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base + , unpacked-validation + , QuickCheck + , quickcheck-classes + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + default-language: Haskell2010 + +------------------------------------------------------------------------------- + +source-repository head + type: git + location: https://github.com/chessai/unpacked-validation + +--------------------------------------------------------------------------------