├── .gitignore ├── psc-package.json ├── README.md ├── bower.json ├── test └── Main.purs └── src ├── Data └── ValidationSelective.purs └── Control └── Selective.purs /.gitignore: -------------------------------------------------------------------------------- 1 | .psc-ide-port 2 | /output 3 | /.psc-package 4 | /.psci_modules 5 | /bower_components 6 | -------------------------------------------------------------------------------- /psc-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "selective", 3 | "set": "psc-0.12.0", 4 | "source": "https://github.com/purescript/package-sets.git", 5 | "depends": [ 6 | "generics-rep", 7 | "validation", 8 | "psci-support", 9 | "effect", 10 | "either", 11 | "prelude" 12 | ] 13 | } 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ### Selective applicative functors 2 | 3 | This is a PureScript fork of [selective applicative functors](https://github.com/snowleopard/selective) by Andrey Mokhov. 4 | `Selective` is a typeclass somewhere between `Applicative` and `Monad`. 5 | 6 | Read more about `Selective` [here](https://blogs.ncl.ac.uk/andreymokhov/selective/). -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-selective", 3 | "version": "0.1.0", 4 | "license": "MIT", 5 | "repository": { 6 | "type": "git", 7 | "url": "git://github.com/anttih/purescript-selective.git" 8 | }, 9 | "ignore": [ 10 | "**/.*", 11 | "node_modules", 12 | "bower_components", 13 | "output" 14 | ], 15 | "dependencies": { 16 | "purescript-prelude": "^4.0.1", 17 | "purescript-validation": "^4.0.0", 18 | "purescript-effect": "^2.0.0", 19 | "purescript-either": "^4.0.0" 20 | }, 21 | "devDependencies": { 22 | "purescript-psci-support": "^4.0.0", 23 | "purescript-generics-rep": "^6.0.0" 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Control.Selective (class Selective, ifS) 6 | import Data.Generic.Rep (class Generic) 7 | import Data.Generic.Rep.Show (genericShow) 8 | import Data.ValidationSelective (VS, invalid) 9 | import Effect (Effect) 10 | import Effect.Console as Console 11 | 12 | type Radius = Int 13 | type Width = Int 14 | type Height = Int 15 | 16 | data Shape = Circle Radius | Rectangle Width Height 17 | 18 | derive instance genericShape :: Generic Shape _ 19 | 20 | instance showShape :: Show Shape where 21 | show = genericShow 22 | 23 | shape :: forall f. Selective f => f Boolean -> f Radius -> f Width -> f Height -> f Shape 24 | shape s r w h = ifS s (Circle <$> r) (Rectangle <$> w <*> h) 25 | 26 | main :: Effect Unit 27 | main = do 28 | Console.logShow $ ifS (pure true) (pure 1) (pure 2) :: VS (Array String) Int 29 | Console.logShow $ shape 30 | (pure false) 31 | (invalid ["no radius"]) 32 | (invalid ["no width"]) (invalid ["no height"]) -------------------------------------------------------------------------------- /src/Data/ValidationSelective.purs: -------------------------------------------------------------------------------- 1 | module Data.ValidationSelective 2 | ( VS 3 | , invalid 4 | , isValid 5 | ) where 6 | 7 | import Prelude 8 | 9 | import Control.Selective (class Selective) 10 | import Data.Either (Either(..), isRight) 11 | import Data.Eq (class Eq1) 12 | import Data.Ord (class Ord1) 13 | import Data.Validation.Semigroup (V, toEither) 14 | import Data.Validation.Semigroup as Validation 15 | 16 | newtype VS e a = VS (V e a) 17 | 18 | -- | Fail with a validation error. 19 | invalid :: forall err result. err -> VS err result 20 | invalid = VS <<< Validation.invalid 21 | 22 | -- | Test whether validation was successful or not. 23 | isValid :: forall err result. VS err result -> Boolean 24 | isValid (VS x) = isRight (toEither x) 25 | 26 | derive instance eqVS :: (Eq e, Eq a) => Eq (VS e a) 27 | derive instance eq1VS :: Eq e => Eq1 (VS e) 28 | 29 | derive instance ordVS :: (Ord e, Ord a) => Ord (VS e a) 30 | derive instance ord1VS :: Ord e => Ord1 (VS e) 31 | 32 | instance showV :: (Show err, Show result) => Show (VS err result) where 33 | show (VS x) = case (toEither x) of 34 | Left err -> "invalid (" <> show err <> ")" 35 | Right result -> "pure (" <> show result <> ")" 36 | 37 | derive newtype instance functorVS :: Functor (VS e) 38 | derive newtype instance applyVS :: Semigroup e => Apply (VS e) 39 | derive newtype instance applicativeVS :: Semigroup e => Applicative (VS e) 40 | 41 | instance selectiveVS :: Semigroup e => Selective (VS e) where 42 | handle (VS x) (VS y) = handle' (toEither x) (toEither y) 43 | where 44 | handle' x' y' = case x', y' of 45 | Right (Left a), Right f -> pure (f a) 46 | Right (Left a), Left e -> invalid e 47 | Right (Right b), _ -> pure b 48 | Left e1, Left e2 -> invalid (e1 <> e2) 49 | Left e, _ -> invalid e -------------------------------------------------------------------------------- /src/Control/Selective.purs: -------------------------------------------------------------------------------- 1 | module Control.Selective where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (lmap) 6 | import Data.Either (Either(..)) 7 | import Data.Maybe (Maybe, maybe) 8 | import Effect (Effect) 9 | 10 | -- | `Selective` is a typeclass somewhere between `Applicative` and `Monad`. 11 | -- | It adds the ability to have conditionals on top of `Applicative`s yet 12 | -- | still allows static analyzis of the program. 13 | -- | 14 | -- | We can leverage the default Monad implementation for many of the instances 15 | -- | since they are Monads anyway. We still get the benefits though. 16 | class Applicative f <= Selective f where 17 | handle :: forall a b. f (Either a b) -> f (a -> b) -> f b 18 | 19 | infixl 4 handle as <*? 20 | 21 | instance selectiveIO :: Selective Effect where 22 | handle = handleM 23 | 24 | instance selectiveArray :: Selective Array where 25 | handle = handleM 26 | 27 | instance selectiveMaybe :: Selective Maybe where 28 | handle = handleM 29 | 30 | 31 | select :: forall f a b c. Selective f => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c 32 | select i t e = map (map Left) i <*? map (map Right) t <*? e 33 | 34 | handleM :: forall f a b. Monad f => f (Either a b) -> f (a -> b) -> f b 35 | handleM i t = do 36 | res <- i 37 | case res of 38 | Left a -> t >>= \f -> pure (f a) 39 | Right b -> pure b 40 | 41 | ifS :: forall f a. Selective f => f Boolean -> f a -> f a -> f a 42 | ifS i t e = select (map (bool (Left unit) (Right unit)) i) (map const t) (map const e) 43 | where 44 | bool x y test = if test then x else y 45 | 46 | whenS :: forall f. Selective f => f Boolean -> f Unit -> f Unit 47 | whenS i t = ifS i t (pure unit) 48 | 49 | fromMaybeS :: forall f a. Selective f => f a -> f (Maybe a) -> f a 50 | fromMaybeS t i = handle ((maybe (Left unit) Right) <$> i) (const <$> t) 51 | 52 | orElse :: forall f e a. Selective f => Semigroup e => f (Either e a) -> f (Either e a) -> f (Either e a) 53 | orElse i t = handle (map (map Right) i) (map (\t' e -> lmap (e <> _) t') t) 54 | 55 | orS :: forall f. Selective f => f Boolean -> f Boolean -> f Boolean 56 | orS test alt = ifS test (pure true) alt 57 | 58 | infixl 4 orS as <||> 59 | 60 | andS :: forall f. Selective f => f Boolean -> f Boolean -> f Boolean 61 | andS test t = ifS test t (pure false) 62 | 63 | infixl 4 andS as <&&> 64 | --------------------------------------------------------------------------------