packages feed

validation (empty) → 0.3.0

raw patch · 5 files changed

+588/−0 lines, 5 filesdep +QuickCheckdep +basedep +bifunctorsbuild-type:Customsetup-changed

Dependencies added: QuickCheck, base, bifunctors, directory, doctest, filepath, lens, semigroupoids, semigroups

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2010-2012 Tony Morris, Nick Partridge++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.
+ Setup.lhs view
@@ -0,0 +1,44 @@+#!/usr/bin/env runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
+ src/Data/Validation.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Data types similar to @Data.Either@ that are explicit about failure and success.+module Data.Validation+(+  -- * Data types+  AccValidation+, Validation+, ValidationT(..)+  -- * Prisms+, Validate(..)+  -- * Isomorphisms+, isoAccValidationEither+, isoValidationEither+, isoAccValidationValidation+) where++import Control.Applicative(Applicative(..), Alternative(..), liftA2, (<$>))+import Control.Lens.Prism(Prism, prism)+import Control.Lens.Iso(Swapped(..), Iso', iso)+import Control.Lens.Review((#))+import Control.Monad(Monad(..))+import Data.Bifoldable(Bifoldable(..))+import Data.Bifunctor(Bifunctor(..))+import Data.Bitraversable(Bitraversable(..))+import Data.Data(Data)+import Data.Either(Either(..))+import Data.Eq(Eq)+import Data.Foldable(Foldable(..))+import Data.Function((.), flip)+import Data.Functor(Functor(..))+import Data.Functor.Alt(Alt(..))+import Data.Functor.Apply(Apply(..))+import Data.Functor.Bind(Bind(..), liftF2)+import Data.Monoid(Monoid(..))+import Data.Ord(Ord)+import Data.Semigroup(Semigroup(..))+import Data.Traversable(Traversable(..))+import Data.Typeable(Typeable)+import Prelude(Show)++-- $setup+-- >>> import Prelude(Num(..))+-- >>> import Data.Eq(Eq(..))+-- >>> import Data.String(String)+-- >>> import Data.Int(Int)+-- >>> import Test.QuickCheck+-- >>> import Data.Either(either)+-- >>> instance (Arbitrary err, Arbitrary a) => Arbitrary (AccValidation err a) where arbitrary = fmap (either (_Failure #) (_Success #)) arbitrary+-- >>> instance (Arbitrary err, Arbitrary a) => Arbitrary (Validation err a) where arbitrary = fmap (either (_Failure #) (_Success #)) arbitrary+-- >>> instance (Applicative m, Arbitrary err, Arbitrary a) => Arbitrary (ValidationT m err a) where arbitrary = fmap (ValidationT . pure) arbitrary++-- | 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 :: AccValidation String Int+-- AccSuccess 8+--+-- >>> _Failure # ["f1"] <*> _Success # 7 :: AccValidation [String] Int+-- AccFailure ["f1"]+--+-- >>> _Success # (+1) <*> _Failure # ["f2"] :: AccValidation [String] Int+-- AccFailure ["f2"]+--+-- >>> _Failure # ["f1"] <*> _Failure # ["f2"] :: AccValidation [String] Int+-- 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 Semigroup err => Apply (AccValidation err) where+  AccFailure e1 <.> AccFailure e2 =+    AccFailure (e1 <> e2)+  AccFailure e1 <.> AccSuccess _  =+    AccFailure e1+  AccSuccess _  <.> AccFailure e2 =+    AccFailure e2+  AccSuccess f  <.> AccSuccess a  =+    AccSuccess (f a)++instance Semigroup err => Applicative (AccValidation err) where+  pure =+    AccSuccess+  (<*>) =+    (<.>)++instance Semigroup err => Alt (AccValidation err) where+  AccFailure _ <!> x =+    x+  AccSuccess a <!> _ =+    AccSuccess a++instance (Semigroup err, Monoid err) => Alternative (AccValidation err) where+  AccFailure _ <|> x =+    x+  AccSuccess a <|> _ =+    AccSuccess a+  empty =+    AccFailure mempty++instance Foldable (AccValidation err) where+  foldr f x (AccSuccess a) =+    f a x+  foldr _ x (AccFailure _) =+    x++instance Traversable (AccValidation err) where+  traverse f (AccSuccess a) =+    AccSuccess <$> f a+  traverse _ (AccFailure e) =+    pure (AccFailure e)++instance Bifunctor AccValidation where+  bimap f _ (AccFailure e) =+    AccFailure (f e)+  bimap _ g (AccSuccess a) =+    AccSuccess (g a)++instance Bifoldable AccValidation where+  bifoldr _ g x (AccSuccess a) =+    g a x+  bifoldr f _ x (AccFailure e) =+    f e x++instance Bitraversable AccValidation where+  bitraverse _ g (AccSuccess a) =+    AccSuccess <$> g a+  bitraverse f _ (AccFailure e) =+    AccFailure <$> f e++-- |+--+-- prop> ((x <> y) <> z) == (x <> (y <> z :: AccValidation [String] Int))+instance Semigroup e => Semigroup (AccValidation e a) where+  AccFailure e1 <> AccFailure e2 =+    AccFailure (e1 <> e2)+  AccFailure _ <> AccSuccess a2  =+    AccSuccess a2+  AccSuccess a1  <> AccFailure _ =+    AccSuccess a1+  AccSuccess a1 <> AccSuccess _ =+    AccSuccess a1++-- |+--+-- prop> ((x `mappend` y) `mappend` z) == (x `mappend` (y `mappend` z :: AccValidation [String] Int))+--+-- prop> mempty `mappend` x == (x :: AccValidation [String] Int)+--+-- prop> x `mappend` mempty == (x :: AccValidation [String] Int)+instance Monoid e => Monoid (AccValidation e a) where+  AccFailure e1 `mappend` AccFailure e2 =+    AccFailure (e1 `mappend` e2)+  AccFailure _ `mappend` AccSuccess a2  =+    AccSuccess a2+  AccSuccess a1  `mappend` AccFailure _ =+    AccSuccess a1+  AccSuccess a1 `mappend` AccSuccess _ =+    AccSuccess a1+  mempty =+    AccFailure mempty++-- | A value of the type @err@ or @a@ and isomorphic to @Data.Either@.+--+-- >>> _Success # (+1) <*> _Success # 7 :: Validation String Int+-- Success 8+--+-- >>> _Failure # ["f1"] <*> _Success # 7 :: Validation [String] Int+-- Failure ["f1"]+--+-- >>> _Success # (+1) <*> _Failure # ["f2"] :: Validation [String] Int+-- Failure ["f2"]+--+-- >>> _Failure # ["f1"] <*> _Failure # ["f2"] :: Validation [String] Int+-- Failure ["f1"]+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 Apply (Validation err) where+  Failure e1 <.> Failure _  =+    Failure e1+  Failure e1 <.> Success _  =+    Failure e1+  Success _  <.> Failure e2 =+    Failure e2+  Success f  <.> Success a  =+    Success (f a)++instance Applicative (Validation err) where+  pure =+    Success+  (<*>) =+    (<.>)++instance Alt (Validation err) where+  Failure _ <!> x =+    x+  Success a <!> _ =+    Success a++instance Monoid err => Alternative (Validation err) where+  Failure _ <|> x =+    x+  Success a <|> _ =+    Success a+  empty =+    Failure mempty++instance Foldable (Validation err) where+  foldr f x (Success a) =+    f a x+  foldr _ x (Failure _) =+    x++instance Traversable (Validation err) where+  traverse f (Success a) =+    Success <$> f a+  traverse _ (Failure e) =+    pure (Failure e)++instance Bifunctor Validation where+  bimap f _ (Failure e) =+    Failure (f e)+  bimap _ g (Success a) =+    Success (g a)++instance Bifoldable Validation where+  bifoldr _ g x (Success a) =+    g a x+  bifoldr f _ x (Failure e) =+    f e x++instance Bitraversable Validation where+  bitraverse _ g (Success a) =+    Success <$> g a+  bitraverse f _ (Failure e) =+    Failure <$> f e++instance Bind (Validation err) where+  Failure e >>- _ =+    Failure e+  Success a >>- f =+    f a++instance Monad (Validation err) where+  return =+    Success+  (>>=) =+    (>>-)++-- | 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 Apply m => Apply (ValidationT m err) where+  ValidationT f <.> ValidationT a =+    ValidationT (liftF2 (<.>) f a)++instance Applicative m => Applicative (ValidationT m err) where+  pure =+    ValidationT . pure . pure+  ValidationT f <*> ValidationT a =+    ValidationT (liftA2 (<*>) f a)++instance (Functor m, Monad m) => Alt (ValidationT m err) where+  ValidationT x <!> ValidationT y =+    ValidationT (x >>= \q -> case q of+      Failure _ -> y+      Success a -> return (Success a))++instance (Applicative m, Monad m, Monoid err) => Alternative (ValidationT m err) where+  ValidationT x <|> ValidationT y =+    ValidationT (x >>= \q -> case q of+      Failure _ -> y+      Success a -> return (Success a))+  empty =+    ValidationT (pure (Failure mempty))++instance Foldable m => Foldable (ValidationT m err) where+  foldr f z (ValidationT x) =+    foldr (flip (foldr f)) z x++instance Traversable m => Traversable (ValidationT m err) where+  traverse f (ValidationT x) =+      ValidationT <$> traverse (traverse f) x++instance Functor m => Bifunctor (ValidationT m) where+  bimap f g (ValidationT x) =+    ValidationT (fmap (bimap f g) x)++instance Foldable m => Bifoldable (ValidationT m) where+  bifoldr f g z (ValidationT x) =+    foldr (flip (bifoldr f g)) z x++instance Traversable m => Bitraversable (ValidationT m) where+  bitraverse f g (ValidationT x) =+    ValidationT <$> traverse (bitraverse f g) x++instance (Apply m, Monad m) => Bind (ValidationT m err) where+  ValidationT v >>- f =+    ValidationT (v >>= \w -> case w of+                               Failure e -> return (Failure e)+                               Success a -> runValidationT (f a))++instance Monad m => Monad (ValidationT m err) where+  return =+    ValidationT . return . pure+  ValidationT v >>= f =+    ValidationT (v >>= \w -> case w of+                               Failure e -> return (Failure e)+                               Success a -> runValidationT (f a))++class Validate f where+  _Failure ::+    Prism (f e1 a) (f e2 a) e1 e2+  _Success ::+    Prism (f e a) (f e b) a b++instance Validate AccValidation where+  _Success =+    prism AccSuccess (\v -> case v of+                              AccFailure e -> Left (AccFailure e)+                              AccSuccess a -> Right a)+  _Failure =+    prism AccFailure (\v -> case v of+                              AccFailure e -> Right e+                              AccSuccess a -> Left (AccSuccess a))++instance Validate Validation where+  _Success =+    prism Success (\v -> case v of+                              Failure e -> Left (Failure e)+                              Success a -> Right a)+  _Failure =+    prism Failure (\v -> case v of+                              Failure e -> Right e+                              Success a -> Left (Success a))++instance Swapped AccValidation where+  swapped =+    iso+      (\v -> case v of+               AccFailure e -> AccSuccess e+               AccSuccess a -> AccFailure a)+      (\v -> case v of+               AccFailure a -> AccSuccess a+               AccSuccess e -> AccFailure e)++instance Swapped Validation where+  swapped =+    iso+      (\v -> case v of+               Failure e -> Success e+               Success a -> Failure a)+      (\v -> case v of+               Failure a -> Success a+               Success e -> Failure e)++instance Functor f => Swapped (ValidationT f) where+  swapped =+    iso+      (\(ValidationT x) -> ValidationT (fmap (swapped #) x))+      (\(ValidationT x) -> ValidationT (fmap (swapped #) x))++isoAccValidationEither ::+  Iso' (AccValidation e a) (Either e a)+isoAccValidationEither =+  iso+    (\v -> case v of+             AccFailure e -> Left e+             AccSuccess a -> Right a)+    (\v -> case v of+             Left e -> AccFailure e+             Right a -> AccSuccess a)++isoValidationEither ::+  Iso' (Validation e a) (Either e a)+isoValidationEither =+  iso+    (\v -> case v of+             Failure e -> Left e+             Success a -> Right a)+    (\v -> case v of+             Left e -> Failure e+             Right a -> Success a)++isoAccValidationValidation ::+  Iso' (AccValidation e a) (Validation e a)+isoAccValidationValidation =+  iso+    (\v -> case v of+             AccFailure e -> Failure e+             AccSuccess a -> Success a)+    (\v -> case v of+             Failure e -> AccFailure e+             Success a -> AccSuccess a)
+ test/doctests.hs view
@@ -0,0 +1,32 @@+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++main ::+  IO ()+main =+  getSources >>= \sources -> doctest $+      "-isrc"+    : "-idist/build/autogen"+    : "-optP-include"+    : "-optPdist/build/autogen/cabal_macros.h"+    : "-hide-all-packages"+    : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ validation.cabal view
@@ -0,0 +1,68 @@+name:               validation+version:            0.3.0+license:            BSD3+license-file:       LICENSE+author:             Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>, Nick Partridge+maintainer:         Tony Morris, Nick Partridge+copyright:          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+homepage:           https://github.com/tonymorris/validation+bug-reports:        https://github.com/tonymorris/validation/issues+cabal-version:      >= 1.10+build-type:         Custom++source-repository   head+  type:             git+  location:         git@github.com:tonymorris/validation.git++flag                small_base+  description:      Choose the new, split-up base package.++library+  default-language:+                    Haskell2010++  build-depends:+                    base < 5 && >= 3+                    , semigroups >= 0.8+                    , semigroupoids >= 4.0+                    , bifunctors >= 3.0+                    , lens >= 4.0++  ghc-options:+                    -Wall++  default-extensions:+                      NoImplicitPrelude++  hs-source-dirs:+                    src++  exposed-modules:+                    Data.Validation++test-suite doctests+  type:+                    exitcode-stdio-1.0++  main-is:+                    doctests.hs++  default-language:+                    Haskell2010++  build-depends:+                    base < 5 && >= 3,+                    doctest >= 0.9.7,+                    filepath >= 1.3,+                    directory >= 1.1,+                    QuickCheck >= 2.0++  ghc-options:+                    -Wall+                    -threaded++  hs-source-dirs:+                    test