unpacked-validation (empty) → 0.1.0.0
raw patch · 5 files changed
+484/−0 lines, 5 filesdep +QuickCheckdep +basedep +deepseqsetup-changed
Dependencies added: QuickCheck, base, deepseq, ghc-prim, quickcheck-classes, unpacked-either, unpacked-validation, validation
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- src/Data/Validation/Unpacked.hs +325/−0
- test/Main.hs +72/−0
- unpacked-validation.cabal +57/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Validation/Unpacked.hs view
@@ -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 <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 #-}
+ test/Main.hs view
@@ -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
+ unpacked-validation.cabal view
@@ -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++--------------------------------------------------------------------------------