selective 0.3 → 0.4
raw patch · 7 files changed
+391/−30 lines, 7 files
Files
- CHANGES.md +4/−0
- LICENSE +1/−1
- README.md +1/−18
- selective.cabal +3/−2
- src/Control/Selective.hs +5/−1
- src/Control/Selective/Multi.hs +294/−0
- test/Sketch.hs +83/−8
CHANGES.md view
@@ -1,5 +1,9 @@ # Change log +## 0.4++* Add multi-way selective functors: `Control.Selective.Multi`.+ ## 0.3 * Add freer rigid selective functors: `Control.Selective.Rigid.Freer`.
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018 Andrey Mokhov+Copyright (c) 2018-2020 Andrey Mokhov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
README.md view
@@ -2,26 +2,9 @@ [](https://hackage.haskell.org/package/selective) [](https://travis-ci.org/snowleopard/selective) [](https://ci.appveyor.com/project/snowleopard/selective) - This is a library for *selective applicative functors*, or just *selective functors* for short, an abstraction between applicative functors and monads, introduced in-[this paper](https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf).--Abstract of the paper:--Applicative functors and monads have conquered the world of functional programming by-providing general and powerful ways of describing effectful computations using pure-functions. Applicative functors provide a way to compose *independent effects* that-cannot depend on values produced by earlier computations, and all of which are declared-statically. Monads extend the applicative interface by making it possible to compose-*dependent effects*, where the value computed by one effect determines all subsequent-effects, dynamically.--This paper introduces an intermediate abstraction called *selective applicative functors*-that requires all effects to be declared statically, but provides a way to select which-of the effects to execute dynamically. We demonstrate applications of the new-abstraction on several examples, including two real-life case studies.-+[this paper](https://dl.acm.org/ft_gateway.cfm?id=3341694). ## What are selective functors?
selective.cabal view
@@ -1,11 +1,11 @@ name: selective-version: 0.3+version: 0.4 synopsis: Selective applicative functors license: MIT license-file: LICENSE author: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard maintainer: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard-copyright: Andrey Mokhov, 2018-2019+copyright: Andrey Mokhov, 2018-2020 homepage: https://github.com/snowleopard/selective category: Control build-type: Simple@@ -36,6 +36,7 @@ hs-source-dirs: src exposed-modules: Control.Selective, Control.Selective.Free,+ Control.Selective.Multi, Control.Selective.Rigid.Free, Control.Selective.Rigid.Freer build-depends: base >= 4.7 && < 5,
src/Control/Selective.hs view
@@ -22,7 +22,10 @@ foldS, anyS, allS, bindS, Cases, casesEnum, cases, matchS, matchM, -- * Selective functors- SelectA (..), SelectM (..), Over (..), Under (..), Validation (..)+ SelectA (..), SelectM (..), Over (..), Under (..), Validation (..),++ -- * Miscellaneous+ swapEither, ComposeEither (..) ) where import Control.Applicative@@ -473,6 +476,7 @@ toArrow (ArrowMonad f) = arr (\x -> ((), x)) >>> first f >>> arr (uncurry ($)) ---------------------------------- Alternative ---------------------------------+-- | Composition of a functor @f@ with the 'Either' monad. newtype ComposeEither f e a = ComposeEither (f (Either e a)) deriving Functor
+ src/Control/Selective/Multi.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE DeriveFunctor, GADTs, RankNTypes, TupleSections, TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Selective.Multi+-- Copyright : (c) Andrey Mokhov 2018-2020+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- This is a library for /selective applicative functors/, or just+-- /selective functors/ for short, an abstraction between applicative functors+-- and monads, introduced in this paper:+-- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf.+--+-- This module defines /multi-way selective functors/, which are more efficient+-- when selecting from a large number of options. They also fully subsume the+-- 'Applicative' type class because they allow to express the notion of+-- independet effects.+--+-- This definition is inspired by the following construction by Daniel Peebles,+-- with the main difference being the added @Enumerable@ constraint:+-- https://gist.github.com/copumpkin/d5bdbc7afda54ff04049b6bdbcffb67e+--+-----------------------------------------------------------------------------+module Control.Selective.Multi (+ -- * Generalised sum types+ Sigma (..), inject, Zero, One (..), Two (..), Many (..), many, matchPure,+ eitherToSigma, sigmaToEither,++ -- * Selective functors+ Some (..), Enumerable (..), Selective (..), Over (..), Under (..), select,+ branch, apS, bindS,++ -- * Applicative functors+ ApplicativeS (..), ap, matchA,++ -- * Monads+ MonadS (..), bind, matchM,++ -- * Generalised products and various combinators+ type (~>), Pi, project, identity, compose, apply, toSigma, fromSigma, toPi,+ fromPi, pairToPi, piToPair, Case (..), matchCases,+ ) where++import Control.Applicative ((<**>))+import Data.Functor.Identity+import Data.Semigroup ((<>))++------------------------ Meet two friends: Sigma and Pi ------------------------+-- | A generalised sum type where @t@ stands for the type of constructor "tags".+-- Each tag has a type parameter @x@ which determines the type of the payload.+-- A 'Sigma' @t@ value therefore contains a payload whose type is not visible+-- externally but is revealed when pattern-matching on the tag.+--+-- See 'Two', 'eitherToSigma' and 'sigmaToEither' for an example.+data Sigma t where+ Sigma :: t x -> x -> Sigma t++-- | An injection into a generalised sum. An alias for 'Sigma'.+inject :: t x -> x -> Sigma t+inject = Sigma++-- | A data type defining no tags. Similar to 'Data.Void.Void' but parameterised.+data Zero a where++-- | A data type with a single tag. This data type is commonly known as @Refl@,+-- see "Data.Type.Equality".+data One a b where+ One :: One a a++-- | A data type with two tags 'A' and 'B' that allows us to encode the good old+-- 'Either' as 'Sigma' 'Two', where the tags 'A' and 'B' correspond to 'Left'+-- and 'Right', respectively. See 'eitherToSigma' and 'sigmaToEither' that+-- witness the isomorphism between 'Either' @a b@ and 'Sigma' @(@'Two'@ a b)@.+data Two a b c where+ A :: Two a b a+ B :: Two a b b++-- | Encode 'Either' into a generalised sum type.+eitherToSigma :: Either a b -> Sigma (Two a b)+eitherToSigma = \case+ Left a -> inject A a+ Right b -> inject B b++-- | Decode 'Either' from a generalised sum type.+sigmaToEither :: Sigma (Two a b) -> Either a b+sigmaToEither = \case+ Sigma A a -> Left a+ Sigma B b -> Right b++-- | A potentially uncountable collection of tags for the same unit @()@ payload.+data Many a b where+ Many :: a -> Many a ()++many :: a -> Sigma (Many a)+many a = Sigma (Many a) ()++-- | Generalised pattern matching on a Sigma type using a Pi type to describe+-- how to handle each case.+--+-- This is a specialisation of 'matchCases' for @f = Identity@. We could also+-- have also given it the following type:+--+-- @+-- matchPure :: Sigma t -> (t ~> Case Identity a) -> a+-- @+--+-- We chose to simplify it by inlining '~>', 'Case' and 'Identity'.+matchPure :: Sigma t -> (forall x. t x -> x -> a) -> a+matchPure (Sigma t x) pi = pi t x++------------------------- Mutli-way selective functors -------------------------+-- | Hide the type of the payload a tag.+--+-- There is a whole library dedicated to this nice little GADT:+-- http://hackage.haskell.org/package/some.+data Some t where+ Some :: t a -> Some t++-- | A class of tags that can be enumerated.+--+-- An valid instance must list every tag in the resulting list exactly once.+class Enumerable t where+ enumerate :: [Some t]++instance Enumerable Zero where+ enumerate = []++instance Enumerable (One a) where+ enumerate = [Some One]++instance Enumerable (Two a b) where+ enumerate = [Some A, Some B]++instance Enum a => Enumerable (Many a) where+ enumerate = [ Some (Many x) | x <- enumFrom (toEnum 0) ]++-- | Multi-way selective functors. Given a computation that produces a value of+-- a sum type, we can 'match' it to the corresponding computation in a given+-- product type.+--+-- For greater similarity with 'matchCases', we could have given the following+-- type to 'match':+--+-- @+-- match :: f (Sigma t) -> (t ~> Case f a) -> f a+-- @+--+-- We chose to simplify it by inlining '~>' and 'Case'.+class Applicative f => Selective f where+ match :: Enumerable t => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a++-- | The basic "if-then" selection primitive from "Control.Selective".+select :: Selective f => f (Either a b) -> f (a -> b) -> f b+select x f = match (eitherToSigma <$> x) $ \case+ A -> f+ B -> pure id++-- | Choose a matching effect with 'Either'.+branch :: Selective f => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c+branch x f g = match (eitherToSigma <$> x) $ \case+ A -> f+ B -> g++-- | Recover the application operator '<*>' from 'match'.+apS :: Selective f => f a -> f (a -> b) -> f b+apS x f = match (inject One <$> x) (\One -> f)++-- | A restricted version of monadic bind.+bindS :: (Enum a, Selective f) => f a -> (a -> f b) -> f b+bindS x f = match (many <$> x) (\(Many x) -> const <$> f x)++-- | Static analysis of selective functors with over-approximation.+newtype Over m a = Over { getOver :: m }+ deriving (Eq, Functor, Ord, Show)++instance Monoid m => Applicative (Over m) where+ pure _ = Over mempty+ Over x <*> Over y = Over (mappend x y)++instance Monoid m => Selective (Over m) where+ match (Over m) pi = Over (mconcat (m : ms))+ where+ ms = [ getOver (pi t) | Some t <- enumerate ]++-- | Static analysis of selective functors with under-approximation.+newtype Under m a = Under { getUnder :: m }+ deriving (Eq, Functor, Ord, Show)++instance Monoid m => Applicative (Under m) where+ pure _ = Under mempty+ Under x <*> Under y = Under (mappend x y)++instance Monoid m => Selective (Under m) where+ match (Under m) _ = Under m++-- | An alternative definition of applicative functors, as witnessed by 'ap' and+-- 'matchOne'. This class is almost like 'Selective' but has a strict constraint+-- on @t@.+class Functor f => ApplicativeS f where+ pureA :: a -> f a+ matchOne :: t ~ One x => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a++-- | Recover the application operator '<*>' from 'matchOne'.+ap :: ApplicativeS f => f a -> f (a -> b) -> f b+ap x f = matchOne (inject One <$> x) (\One -> f)++-- | Every 'Applicative' is also an 'ApplicativeS'.+matchA :: (Applicative f, t ~ One x) => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a+matchA x pi = (\case (Sigma One x) -> x) <$> x <**> pi One++-- | An alternative definition of monads, as witnessed by 'bind' and 'matchM'.+-- This class is almost like 'Selective' but has no the constraint on @t@.+class Applicative f => MonadS f where+ matchUnconstrained :: f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a++-- Adapted from the original implementation by Daniel Peebles:+-- https://gist.github.com/copumpkin/d5bdbc7afda54ff04049b6bdbcffb67e++-- | Monadic bind.+bind :: MonadS f => f a -> (a -> f b) -> f b+bind x f = matchUnconstrained (many <$> x) (\(Many x) -> const <$> f x)++-- | Every monad is a multi-way selective functor.+matchM :: Monad f => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a+matchM sigma pi = sigma >>= \case Sigma t x -> ($x) <$> pi t++-- | A generalised product type (Pi), which holds an appropriately tagged+-- payload @u x@ for every possible tag @t x@.+--+-- Note that this looks different than the standard formulation of Pi types.+-- Maybe it's just all wrong!+--+-- See 'Two', 'pairToPi' and 'piToPair' for an example.+type (~>) t u = forall x. t x -> u x+infixl 4 ~>++-- | A product type where the payload has the type specified with the tag.+type Pi t = t ~> Identity++-- | A projection from a generalised product.+project :: t a -> Pi t -> a+project t pi = runIdentity (pi t)++-- | A trivial product type that stores nothing and simply returns the given tag+-- as the result.+identity :: t ~> t+identity = id++-- | As it turns out, one can compose such generalised products. Why not: given+-- a tag, get the payload of the first product and then pass it as input to the+-- second. This feels too trivial to be useful but is still somewhat cute.+compose :: (u ~> v) -> (t ~> u) -> (t ~> v)+compose = (.)++-- | Update a generalised sum given a generalised product that takes care of all+-- possible cases.+apply :: (t ~> u) -> Sigma t -> Sigma u+apply pi (Sigma t x) = Sigma (pi t) x++-- | Encode a value into a generalised sum type that has a single tag 'One'.+toSigma :: a -> Sigma (One a)+toSigma = inject One++-- | Decode a value from a generalised sum type that has a single tag 'One'.+fromSigma :: Sigma (One a) -> a+fromSigma (Sigma One a) = a++-- | Encode a value into a generalised product type that has a single tag 'One'.+toPi :: a -> Pi (One a)+toPi a One = Identity a++-- | Decode a value from a generalised product type that has a single tag 'One'.+fromPi :: Pi (One a) -> a+fromPi = project One++-- | Encode @(a, b)@ into a generalised product type.+pairToPi :: (a, b) -> Pi (Two a b)+pairToPi (a, b) = \case+ A -> Identity a+ B -> Identity b++-- | Decode @(a, b)@ from a generalised product type.+piToPair :: Pi (Two a b) -> (a, b)+piToPair pi = (project A pi, project B pi)++-- | Handler of a single case in a generalised pattern matching 'matchCases'.+newtype Case f a x = Case { handleCase :: f (x -> a) }++-- | Generalised pattern matching on a Sigma type using a Pi type to describe+-- how to handle each case.+matchCases :: Functor f => Sigma t -> (t ~> Case f a) -> f a+matchCases (Sigma t x) pi = ($x) <$> handleCase (pi t)
test/Sketch.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveFunctor, EmptyCase, GADTs, RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE DeriveFunctor, EmptyCase, FlexibleInstances, GADTs, RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE TypeFamilies #-} module Sketch where import Control.Arrow hiding (first, second)@@ -300,7 +301,7 @@ -- Composition of Starry and Either monad -- See: https://duplode.github.io/posts/applicative-archery.html-class Applicative f => SelectiveS f where+class Applicative f => SelectiveStarry f where (|.|) :: f (Either e (b -> c)) -> f (Either e (a -> b)) -> f (Either e (a -> c)) -- Composition of Monoidal and Either monad@@ -330,11 +331,7 @@ fromM x f = either id (\(a, f) -> f a) <$> (fmap swapEither x |**| fmap Right f) toM :: Selective f => f (Either e a) -> f (Either e b) -> f (Either e (a, b))-toM a b = select ((fmap Left . swapEither) <$> a) ((\e a -> fmap (a,) e) <$> b)---- | Swap @Left@ and @Right@.-swapEither :: Either a b -> Either b a-swapEither = either Right Left+toM = biselect -- Proof that if select = selectM, and <*> = ap, then <*> = apS. apSEqualsApply :: (Selective f, Monad f) => f (a -> b) -> f a -> f b@@ -448,6 +445,28 @@ ((\mbc cd -> maybe (Right Nothing) (\bc -> Left $ fmap ((cd . bc) .)) mbc) <$> y)) ((&) <$> z) +------------------------ McCarthy's Conditional combinator -------------------------+-- See: http://www4.di.uminho.pt/~jno/ps/pdbc.pdf+-- And also: https://themattchan.com/docs/algprog.pdf++-- Guard function used in McCarthy's conditional+-- | It provides information about the outcome of testing @p@ on some input @a@,+-- encoded in terms of the coproduct injections without losing the input+-- @a@ itself.+grdS :: Applicative f => f (a -> Bool) -> f a -> f (Either a a)+grdS f a = (selector <$> (f <*> a)) <*> a+ where+ selector = bool Right Left ++-- | McCarthy's conditional, denoted p -> f,g is a well-known functional+-- combinator, which suggests that, to reason about conditionals, one may +-- seek help in the algebra of coproducts.+--+-- This combinator is very similar to the very nature of the 'select'+-- operator and benefits from a series of properties and laws.+condS :: Selective f => f (b -> Bool) -> f (b -> c) -> f (b -> c) -> f b -> f c +condS p f g = (\r -> branch r f g) . grdS p+ ------------------------ Carter Schonwald's copatterns ------------------------- -- See: https://github.com/cartazio/symmetric-monoidal/blob/15b209953b7d4a47651f615b02dbb0171de8af40/src/Control/Monoidal.hs#L93 -- And also: https://twitter.com/andreymokhov/status/1102648479841701888@@ -469,6 +488,28 @@ chooseS :: Selective f => f (Either a b) -> Choice (f (a -> c)) (f (b -> c)) -> f c chooseS x (Choice c) = branch x (c CLeft) (c CRight) +------------------------------- ApplicativeError -------------------------------+-- See https://twitter.com/LukaJacobowitz/status/1148756733243940864.++class Applicative f => ApplicativeEither f e where+ raise :: e -> f a+ handle :: f a -> f (e -> a) -> f a -- Note that the handler may fail too++-- If the first computation succeeds with an @a@, this function just returns it.+-- Otherwise, it attempts to handle the error @e@ by running the second+-- computation. If the latter fails too, we return the very first error @e@,+-- otherwise we handle the error with the obtained function @e -> a@ and return+-- the resulting value @a@.+handleS :: Selective f => f (Either e a) -> f (Either e (e -> a)) -> f (Either e a)+handleS x y = select (second Right <$> x) (handlePure <$> y)+ where+ handlePure :: Either e (e -> a) -> e -> Either e a+ handlePure (Left _) e = Left e+ handlePure (Right f) e = Right (f e)++instance Selective f => ApplicativeEither (ComposeEither f e) e where+ raise = ComposeEither . pure . Left+ handle (ComposeEither x) (ComposeEither y) = ComposeEither (handleS x y) ------------------------------- Free ArrowChoice ------------------------------- -- A free 'ArrowChoice' built on top of base components @f i o@.@@ -547,6 +588,40 @@ case rx of Done x -> runHaxl (f x) -- dynamic dependency on runtime value 'x' Blocked bx x -> return (Blocked bx (x >>= f)) ++++-- x <*? (y <*? z)++-- 1 0 0+-- 1 1 0+-- 1 1 1++-- (x <*? y) <*? z++-- 1 0 0+-- 1 1 0+-- 1 0 1+-- 1 1 1+++-- data Evaluation e a = Unknown e | Known a | Wrapped (Evaluation e a)+-- deriving (Functor, Show)++-- type E e a = Identity++-- instance Semigroup e => Applicative (Evaluation e) where+-- pure = Known+-- Unknown e1 <*> Unknown e2 = Unknown (e1 <> e2)+-- Unknown e1 <*> Known _ = Unknown e1+-- Known _ <*> Unknown e2 = Unknown e2+-- Known f <*> Known a = Known (f a)++-- instance Semigroup e => Selective (Evaluation e) where+-- select (Known (Right b)) _ = Known b+-- select (Known (Left a)) f = ($a) <$> f+-- select (Unknown e1 ) (Known _ ) = Unknown e1+-- select (Unknown e1 ) (Unknown e2) = Unknown (e1 <> e2) data C f g a where