diff options
| -rw-r--r-- | Makefile | 21 | ||||
| -rw-r--r-- | README.md | 6 | ||||
| -rw-r--r-- | server/migrations/2.sql | 4 | ||||
| -rw-r--r-- | validation/src/Data/Validation.hs | 375 | ||||
| -rw-r--r-- | validation/validation.cabal | 2 |
5 files changed, 397 insertions, 11 deletions
@@ -4,11 +4,6 @@ start: stop: @tmux kill-session -t sharedCost -dist: - @nix-build -o result-server -A ghc.server - @nix-build -o result-client -A ghcjs.client - @nix-shell -p closurecompiler --command 'closure-compiler result-client/bin/client.jsexe/all.js --js_output_file public/javascript/main.js' - clean: clean-server clean-client build: build-server build-client cp-client @@ -49,3 +44,19 @@ run-server: watch-server: @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(tput reset && make build-server-inside && make run-server) || :'" + +# Deploy +# ------ + +deploy: + @make clean + @nix-build -o result-server -A ghc.server + @nix-build -o result-client -A ghcjs.client + @nix-shell -p closurecompiler --command 'closure-compiler result-client/bin/client.jsexe/all.js --js_output_file public/javascript/main.js' + @rm -rf bundle + @mkdir bundle + @cp application.conf bundle + @cp -r public bundle + @cp result-server/bin/server bundle + @rsync -avzhr bundle/ guyonvarch.me:servers/shared-cost + @rm -rf bundle @@ -41,10 +41,10 @@ Later, stop the environment with: ./make stop ``` -## Dist +## Deploy -``` -make dist +```bash +make deploy ``` ## Configuration diff --git a/server/migrations/2.sql b/server/migrations/2.sql index efed046..c1d502f 100644 --- a/server/migrations/2.sql +++ b/server/migrations/2.sql @@ -35,10 +35,10 @@ UPDATE SET category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) WHERE - EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) + EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)); DELETE FROM payment WHERE category = -1; -- Remove -DROP TABLE payment_category +DROP TABLE payment_category; diff --git a/validation/src/Data/Validation.hs b/validation/src/Data/Validation.hs new file mode 100644 index 0000000..e30202f --- /dev/null +++ b/validation/src/Data/Validation.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +#endif + +-- | A data type similar to @Data.Either@ that accumulates failures. +module Data.Validation +( + -- * Data type + Validation(..) + -- * Constructing validations +, validate +, validationNel +, fromEither +, liftError + -- * Functions on validations +, validation +, toEither +, orElse +, valueOr +, ensure +, codiagonal +, validationed +, bindValidation + -- * Prisms + -- | These prisms are useful for writing code which is polymorphic in its + -- choice of Either or Validation. This choice can then be made later by a + -- user, depending on their needs. + -- + -- An example of this style of usage can be found + -- <https://github.com/qfpl/validation/blob/master/examples/src/PolymorphicEmail.hs here> +, _Failure +, _Success + -- * Isomorphisms +, Validate(..) +, revalidate +) where + +import Control.Applicative (Applicative (pure, (<*>)), (<$>)) +import Control.DeepSeq (NFData (rnf)) +import Control.Lens (over, under) +import Control.Lens.Getter ((^.)) +import Control.Lens.Iso (Iso, Swapped (..), from, iso) +import Control.Lens.Prism (Prism, prism) +import Control.Lens.Review (( # )) +import Data.Bifoldable (Bifoldable (bifoldr)) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Bitraversable (Bitraversable (bitraverse)) +import Data.Data (Data) +import Data.Either (Either (Left, Right), either) +import Data.Eq (Eq) +import Data.Foldable (Foldable (foldr)) +import Data.Function (id, ($), (.)) +import Data.Functor (Functor (fmap)) +import Data.Functor.Alt (Alt ((<!>))) +import Data.Functor.Apply (Apply ((<.>))) +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Ord (Ord) +import Data.Semigroup (Semigroup ((<>))) +import Data.Traversable (Traversable (traverse)) +import Data.Typeable (Typeable) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (Generic) +#endif +import Prelude (Maybe (..), Show) + + +-- | An @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 'Data.Functor.Bind.Bind' or '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 = + Failure err + | Success a + deriving ( + Eq, Ord, Show, Data, Typeable +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif + ) + +instance Functor (Validation err) where + fmap _ (Failure e) = + Failure e + fmap f (Success a) = + Success (f a) + {-# INLINE fmap #-} + +instance Semigroup err => Apply (Validation err) where + Failure e1 <.> b = Failure $ case b of + Failure e2 -> e1 <> e2 + Success _ -> e1 + Success _ <.> Failure e2 = + Failure e2 + Success f <.> Success a = + Success (f a) + {-# INLINE (<.>) #-} + +instance Semigroup err => Applicative (Validation err) where + pure = + Success + (<*>) = + (<.>) + +-- | For two errors, this instance reports only the last of them. +instance Alt (Validation err) where + Failure _ <!> x = + x + Success a <!> _ = + Success 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 #-} + +appValidation :: + (err -> err -> err) + -> Validation err a + -> Validation err a + -> Validation err a +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 +{-# INLINE appValidation #-} + +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 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) + {-# INLINE swapped #-} + +instance (NFData e, NFData a) => NFData (Validation e a) where + rnf v = + case v of + Failure e -> rnf e + Success a -> rnf a + +-- | 'validate's an @a@ producing an updated optional value, returning +-- @e@ in the empty case. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- validate :: e -> (a -> Maybe b) -> a -> Validation e b +-- @ +validate :: Validate v => e -> (a -> Maybe b) -> a -> v e b +validate e p a = case p a of + Nothing -> _Failure # e + Just b -> _Success # b + +-- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since +-- they are a common semigroup to use. +validationNel :: Either e a -> Validation (NonEmpty e) a +validationNel = liftError pure + +-- | Converts from 'Either' to 'Validation'. +fromEither :: Either e a -> Validation e a +fromEither = liftError id + +-- | '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 +liftError f = either (Failure . f) Success + +-- | 'validation' is the catamorphism for @Validation@. +validation :: (e -> c) -> (a -> c) -> Validation e a -> c +validation ec ac v = case v of + Failure e -> ec e + Success a -> ac a + +-- | Converts from 'Validation' to 'Either'. +toEither :: Validation e a -> Either e a +toEither = validation Left Right + +-- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- orElse :: Validation e a -> a -> a +-- @ +orElse :: Validate v => v e a -> a -> a +orElse v a = case v ^. _Validation of + Failure _ -> a + Success x -> x + +-- | Return the @a@ or run the given function over the @e@. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- valueOr :: (e -> a) -> Validation e a -> a +-- @ +valueOr :: Validate v => (e -> a) -> v e a -> a +valueOr ea v = case v ^. _Validation of + Failure e -> ea e + Success a -> a + +-- | 'codiagonal' gets the value out of either side. +codiagonal :: Validation a a -> a +codiagonal = valueOr id + +-- | 'ensure' ensures that a validation remains unchanged upon failure, +-- updating a successful validation with an optional value that could fail +-- with @e@ otherwise. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- ensure :: e -> (a -> Maybe b) -> Validation e a -> Validation e b +-- @ +ensure :: Validate v => e -> (a -> Maybe b) -> v e a -> v e b +ensure e p = + over _Validation $ \v -> case v of + Failure x -> Failure x + Success a -> validate e p a + +-- | Run a function on anything with a Validate instance (usually Either) +-- as if it were a function on Validation +-- +-- This can be thought of as having the type +-- +-- @(Either e a -> Either e' a') -> Validation e a -> Validation e' a'@ +validationed :: Validate v => (v e a -> v e' a') -> Validation e a -> Validation e' a' +validationed f = under _Validation f + +-- | @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 v f = case v of + Failure e -> Failure e + Success a -> f a + +-- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic +-- to Validation, and hence isomorphic to Either. +class Validate f where + _Validation :: + Iso (f e a) (f g b) (Validation e a) (Validation g b) + + _Either :: + Iso (f e a) (f g b) (Either e a) (Either g b) + _Either = + iso + (\x -> case x ^. _Validation of + Failure e -> Left e + Success a -> Right a) + (\x -> _Validation # case x of + Left e -> Failure e + Right a -> Success a) + {-# INLINE _Either #-} + +instance Validate Validation where + _Validation = + id + {-# INLINE _Validation #-} + _Either = + iso + (\x -> case x of + Failure e -> Left e + Success a -> Right a) + (\x -> case x of + Left e -> Failure e + Right a -> Success a) + {-# INLINE _Either #-} + +instance Validate Either where + _Validation = + iso + fromEither + toEither + {-# INLINE _Validation #-} + _Either = + id + {-# INLINE _Either #-} + +-- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'Validation'. +_Failure :: + Validate f => + Prism (f e1 a) (f e2 a) e1 e2 +_Failure = + prism + (\x -> _Either # Left x) + (\x -> case x ^. _Either of + Left e -> Right e + Right a -> Left (_Either # Right a)) +{-# INLINE _Failure #-} + +-- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'Validation'. +_Success :: + Validate f => + Prism (f e a) (f e b) a b +_Success = + prism + (\x -> _Either # Right x) + (\x -> case x ^. _Either of + Left e -> Left (_Either # Left e) + Right a -> Right a) +{-# INLINE _Success #-} + +-- | 'revalidate' converts between any two instances of 'Validate'. +revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t) +revalidate = _Validation . from _Validation diff --git a/validation/validation.cabal b/validation/validation.cabal index 6e2458b..60e5444 100644 --- a/validation/validation.cabal +++ b/validation/validation.cabal @@ -1,7 +1,7 @@ name: validation version: 1 license: BSD3 -license-file: LICENCE +license-file: LICENSE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart> maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>, Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ> synopsis: A data-type like Either but with an accumulating Applicative |