The Prio Applicative



Published on May 26, 2015 under the tag An interesting Applicative which lets us prioritize computationsPublished on May 26, 2015 under the tag haskell

Introduction

When writing some code recently, I came across a very interesting Applicative Functor. I wanted to write about it for two reasons:

It really shows the power of Applicative (compared to Monad). Applicative does not require access to previously computed results, which helps in this case, because it allows us to execute statements in whatever order is convenient.

I think it is novel, I was digging for a bit and could not find a similar Applicative in any Haskell code.

This blogpost is written in literate Haskell so you should be able to just load it up in GHCi and play around with it (you can find the raw .lhs file here).

{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}

import Control.Applicative ( Applicative (..), (<$>)) (..), ()) import Control.Monad (forM, liftM, liftM2) (forM, liftM, liftM2) import Control.Monad.State ( State , runState, state) , runState, state) import Unsafe.Coerce (unsafeCoerce) (unsafeCoerce) import Data.List (sortBy) (sortBy) import qualified Data.Map as M import Data.Ord (comparing) (comparing) import qualified Data.OrdPSQ as PSQ import Data.Traversable (traverse) (traverse) import qualified Data.Vector as V import GHC.Exts ( Any )

The problem

In our example, we will be modeling a dessert restaurant.

type Dessert = String

We keep the inventory of our restaurant simply as a list. The important invariant here is that the inventory is always ordered from cheapest to most expensive.

type Inventory = [ Dessert ]

defaultInventory :: Inventory = defaultInventory [ "Pancake" , "Apple Pie" , "Apple Pie" , "Tiramisu" ]

Whenever a client wants to order something, they have two options:

Request a specific dessert;

Just get the cheapest one we have available.

In the first case, they will not get served anything if the specific dessert is out of stock. In the second case, they will only miss out on a dessert when our inventory is completely empty.

data Request = RequestSpecificDessert Dessert | RequestCheapestDessert deriving ( Show )

Let’s implement the logic for serving a request. We use State Inventory to keep track of what’s available.

doRequest :: Request -> State Inventory ( Maybe Dessert )

For RequestCheapestDessert , we make use of the fact that our inventory is sorted by price. This means the head of the list is the cheapest dessert, so we serve that and put the tail of the list ( xs ) back.

We can do that conveniently using the state function, which allows us to modify the state and compute a result at the same time:

state :: (s -> (a, s)) -> State s a (s(a, s))s a

The implementation becomes:

RequestCheapestDessert = doRequest $ \inventory -> case inventory of state\inventoryinventory -> ( Nothing , []) [], []) : xs) -> ( Just dessert, xs) (dessertxs)dessert, xs)

In case the client wants a specific dessert, we use break to take out the requested item from the inventory list.

RequestSpecificDessert requested) = doRequest (requested) $ \inventory -> case break ( == requested) inventory of state\inventoryrequested) inventory : ys) -> ( Just dessert, xs ++ ys) (xs, dessertys)dessert, xsys) -> ( Nothing , xs) (xs, []), xs)

= runState (doRequest RequestCheapestDessert ) defaultInventory test01runState (doRequest) defaultInventory = runState (doRequest ( RequestSpecificDessert "Apple Pie" )) defaultInventory test02runState (doRequest ()) defaultInventory

Let’s check if this works:

*Main> runState (doRequest RequestCheapestDessert) defaultInventory (Just "Pancake",["Apple Pie","Apple Pie","Tiramisu"]) *Main> runState (doRequest (RequestSpecificDessert "Apple Pie")) defaultInventory (Just "Apple Pie",["Pancake","Apple Pie","Tiramisu"])

Looking good so far!

Because our restaurant wants to make as much money as possible, we choose to first serve the people who order a specific dessert. In order to do that, we have a ‘Priority’ type and each kind of request maps to a priority. Lower numbers means higher priority.

type Priority = Int

requestPriority :: Request -> Priority RequestSpecificDessert _) = 0 requestPriority (_) RequestCheapestDessert = 1 requestPriority

Now let’s see what happens when a bunch of friends visit our restaurant.

friendsRequests :: [ Request ] = friendsRequests [ RequestCheapestDessert , RequestSpecificDessert "Apple Pie" , RequestCheapestDessert , RequestSpecificDessert "Pancake" , RequestSpecificDessert "Crème brûlée" ]

Easy: we first sort the requests by priority, and then we apply doRequest on every Request . We keep the requests so we know which Dessert corresponds to which Request .

doRequests :: [ Request ] -> State Inventory [( Request , Maybe Dessert )] [()] = doRequests requests $ forM (sortBy (comparing requestPriority) requests) -> (,) req <$> doRequest req \req(,) reqdoRequest req

Let’s run this for our example to see if it worked and if we got the priorities right:

= runState (doRequests friendsRequests) defaultInventory test03runState (doRequests friendsRequests) defaultInventory

*Main> runState (doRequests friendsRequests) defaultInventory ( [ (RequestSpecificDessert "Apple Pie", Just "Apple Pie") , (RequestSpecificDessert "Pancake", Just "Pancake") , (RequestSpecificDessert "Crème brûlée", Nothing) , (RequestCheapestDessert, Just "Apple Pie") , (RequestCheapestDessert, Just "Tiramisu") ] , [] )

Works great! However, it gets trickier. What if, instead of just a list, we have something with a bit more structure:

data Family a = Family { familyParent1 :: a , familyParent2 :: a , familyChildren :: V.Vector a } deriving ( Show )

And we want to implement:

doFamilyRequests :: Family Request -> State Inventory ( Family ( Maybe Dessert )) )) = error "Implement me" doFamilyRequests

How do we go about that? Instead of just sorting by priority, we need to tag which request belongs to which parent or child, then sort them, and… it gets messy – especially if the problem becomes more complicated. Imagine, for example, that children get given a bit more priority. It would be cool if we could separate the evaluation order (priority) from our actual logic.

Fortunately, there is an Applicative Functor which solves exactly this problem.

The Prio Applicative

The Prio Applicative has three type parameters:

p : The priority type, typically something like Int or Double ;

: The priority type, typically something like or ; m : The Monad we are annotating with priorities, for example State Inventory ;

: The Monad we are annotating with priorities, for example ; a : Our result type.

We use a GADT which mirrors the interface of Applicative, and one additional constructor, which holds a monadic action together with its priority .

data Prio p m a where p m a Pure :: a -> Prio p m a p m a App :: Prio p m (a -> b) -> Prio p m a -> Prio p m b p m (ab)p m ap m b

Prio :: p -> m a -> Prio p m a m ap m a

For reference, here is the interface of Applicative again:

class Functor f => Applicative f where pure :: a -> f a f a (<*>) :: f (a -> b) -> f a -> f b f (ab)f af b

We can define a functor instance in terms of Applicative:

instance Functor ( Prio p m) where p m) fmap f = App ( Pure f) f)

And we can use the constructors to implement the Applicative instance:

instance Applicative ( Prio p m) where p m) pure = Pure ( <*> ) = App

Now, we probably want to hide the actual constructors from the users and just provide a simple interface. Our interface consists of three functions:

prio annotates a monadic action with a priority;

annotates a monadic action with a priority; modifyPrio modifies the priorities in a Prio value;

modifies the priorities in a value; runPrio evaluates the Prio to the base Monad.

The implementation of prio is straightforward:

prio :: p -> m a -> Prio p m a m ap m a = Prio prio

A simple implementation of modifyPrio walks through the tree and modifies priorities ( Prio nodes) as it encounters them .

modifyPrio :: forall p m a . (p -> p) -> Prio p m a -> Prio p m a p m a(pp)p m ap m a = go modifyPrio fgo where go :: forall b . Prio p m b -> Prio p m b p m bp m b Pure x) = Pure x go (x) App x y) = App (go x) (go y) go (x y)(go x) (go y) Prio p x) = Prio (f p) x go (p x)(f p) x

runPrio also has a simple implementation: we find the minimal priority, and then evaluate all actions having this priority. When no priorities are left, we can use unsafeEvaluate to evaluate the whole tree .

runPrio :: ( Monad m, Ord p) => Prio p m a -> m a m,p)p m am a = case findMinimalPriority os of runPrio osfindMinimalPriority os Just p -> evaluatePriority p os >>= runPrio evaluatePriority p osrunPrio Nothing -> return $ unsafeEvaluate os unsafeEvaluate os

The three auxiliary functions used here findMinimalPriority , evaluatePriority and unsafeEvaluate should be hidden from the user-facing API (except perhaps findMinimalPriority ). Let’s look at how these functions are implemented next.

findMinimalPriority simply goes through the Prio value and returns the minimal priority.

findMinimalPriority :: forall p m a . ( Monad m, Ord p) p m am,p) => Prio p m a -> Maybe p p m a = go Nothing findMinimalPrioritygo where go :: forall b . Maybe p -> Prio p m b -> Maybe p p m b ! acc ( Pure _) = acc goacc (_)acc ! acc ( App x y) = go (go acc x) y goacc (x y)go (go acc x) y ! Nothing ( Prio p _) = Just p gop _) ! ( Just ! p0) ( Prio p _) = Just ( min p0 p) gop0) (p _)p0 p)

evaluatePriority evaluates all nodes with a priority equal or less than the given priority. We do so by replacing this Prio constructor by a Pure constructor.

evaluatePriority :: forall p m a . ( Monad m, Ord p) p m am,p) => p -> Prio p m a -> m ( Prio p m a) p m am (p m a) = go evaluatePriority p0go where go :: forall b . Prio p m b -> m ( Prio p m b) p m bm (p m b) Pure x) = return ( Pure x) go (x)x) App x y) = liftM2 App (go x) (go y) go (x y)liftM2(go x) (go y) Prio p f) go (p f) | p <= p0 = liftM Pure f p0liftM | otherwise = return ( Prio p f) p f)

After we have recursively called findMinimalPriority and evaluatePriority until all the Prio nodes are gone, we can call unsafeEvaluate to get our actual value out.

unsafeEvaluate :: Prio p m a -> a p m a Pure x) = x unsafeEvaluate (x) App x y) = (unsafeEvaluate x) (unsafeEvaluate y) unsafeEvaluate (x y)(unsafeEvaluate x) (unsafeEvaluate y) Prio _ _) = error unsafeEvaluate (_ _) "unsafeEvaluate: internal error: some steps still unevaluated"

Usage example

We can now try this out. Remember the type of doRequest :

doRequest :: Request -> State Inventory ( Maybe Dessert )

Let’s add a variant which uses the priority of the Request :

prioRequest :: Request -> Prio Priority ( State Inventory ) ( Maybe Dessert ) ) ( = prio (requestPriority req) (doRequest req) prioRequest reqprio (requestPriority req) (doRequest req)

And for the whole family:

prioFamilyRequests :: Family Request -> Prio Priority ( State Inventory ) ( Family ( Maybe Dessert )) ) ()) family = Family prioFamilyRequests <$> prioRequest (familyParent1 family ) prioRequest (familyParent1 <*> prioRequest (familyParent2 family ) prioRequest (familyParent2 <*> (modifyPrio (\x -> x - 1 ) $ (modifyPrio (\x traverse prioRequest (familyChildren family )) prioRequest (familyChildren))

Ain’t that clean code. Let’s test it out:

familyRequest :: Family Request = Family familyRequest = RequestCheapestDessert { familyParent1 = RequestSpecificDessert "Apple Pie" , familyParent2 = V.fromList , familyChildrenV.fromList [ RequestCheapestDessert , RequestSpecificDessert "Pancake" , RequestSpecificDessert "Crème brûlée" ] }

= runState (runPrio $ prioFamilyRequests familyRequest) defaultInventory test04runState (runPrioprioFamilyRequests familyRequest) defaultInventory

*Main> runState (runPrio $ prioFamilyRequests familyRequest) defaultInventory ( Family { familyParent1 = Just "Tiramisu" , familyParent2 = Just "Apple Pie" , familyChildren = fromList [ Just "Apple Pie" , Just "Pancake" , Nothing ] } , [] )

Correct!

Conclusion

Prio is an interesting Applicative. I particularly like the fact that it works for every Monad (although it doesn’t make sense for some Monads such as Reader ).

Use cases are rare. I’ve only encountered one and I could also have implemented it in a different way (although this feels a lot cleaner). However, I think a really important point about it is that it really illustrates the difference between Applicative and Monad very well.

Thanks to Alex Sayers, Jared Tobin and Maciej Wos for proofreading and discussions.

Appendix: a faster runPrio

= runState (fastRunPrio $ prioFamilyRequests familyRequest) defaultInventory test05runState (fastRunPrioprioFamilyRequests familyRequest) defaultInventory

I have been requested to include the code for a faster runPrio , so here it is. As you might expect, it is not as clean as the original one.

The code runs in roughly three steps:

Build a queue which sorts all the elements by priority. In addition to the priority, we have an Int key per Prio node, determined by position. Evaluate this queue in the arbitrary Monad m . As result we now get a Map which maps this Int key to the value (of type Any ). Run through the original Prio again, and whenever we encounter a Prio node, we use the Int key to lookup and unsafeCoerce the evaluated value from the Map .

fastRunPrio :: forall p m a . ( Monad m, Ord p) => Prio p m a -> m a p m am,p)p m am a = do fastRunPrio prio0 let (queue, _) = buildQueue 0 prio0 PSQ.empty (queue, _)buildQueueprio0 PSQ.empty m <- evaluateQueue queue M.empty evaluateQueue queue M.empty let (x, _) = evalPrio m 0 prio0 (x, _)evalPrio mprio0 return x where

The three steps are implemented in three auxiliary methods, which you can find here: