summaryrefslogtreecommitdiff
path: root/provider
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-02-18 17:31:48 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-02-18 17:31:48 +0000
commit50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062 (patch)
tree4f8cb51eb1848013bff98c7c07b3520e381967cd /provider
parentc87014b8c6f63da98ae331db56e143a982bdd93b (diff)
downloaddirty-haskell.org-50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062.tar
dirty-haskell.org-50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062.tar.gz
dirty-haskell.org-50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062.tar.bz2
dirty-haskell.org-50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062.tar.xz
dirty-haskell.org-50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062.zip
Updated thermoprint-5 with queue management
Diffstat (limited to 'provider')
-rw-r--r--provider/posts/thermoprint-5.md132
1 files changed, 130 insertions, 2 deletions
diff --git a/provider/posts/thermoprint-5.md b/provider/posts/thermoprint-5.md
index 47132e2..0249734 100644
--- a/provider/posts/thermoprint-5.md
+++ b/provider/posts/thermoprint-5.md
@@ -1,7 +1,7 @@
1--- 1---
2title: Building an Extensible Framework for Specifying Compile-Time Configuration using Universal Quantification 2title: Building an Extensible Framework for Specifying Compile-Time Configuration using Universal Quantification
3tags: Thermoprint 3tags: Thermoprint
4published: 2016-01-24 4published: 2016-02-18
5--- 5---
6 6
7When I write *Universal Quantification* I mean what is commonly referred to as 7When I write *Universal Quantification* I mean what is commonly referred to as
@@ -14,6 +14,8 @@ nag me occasionally if this bothers you -- I really should invest some more time
14category theory). Since haskell does not support `exists` we´re required to use the 14category theory). Since haskell does not support `exists` we´re required to use the
15`forall`-version, which really is universally quantified. 15`forall`-version, which really is universally quantified.
16 16
17## Printer Configuration
18
17What we want is to have the user provide us with a set of specifications of how to 19What we want is to have the user provide us with a set of specifications of how to
18interact with one printer each. 20interact with one printer each.
19Something like the following: 21Something like the following:
@@ -31,7 +33,8 @@ The first step in refining this is necessitated by having the user provide the
31[monad-transformer-stack](http://book.realworldhaskell.org/read/monad-transformers.html) 33[monad-transformer-stack](http://book.realworldhaskell.org/read/monad-transformers.html)
32to use at compile time. 34to use at compile time.
33Thus we introduce our first universal quantification (in conjunction with 35Thus we introduce our first universal quantification (in conjunction with
34[polymorphic components](https://prime.haskell.org/wiki/PolymorphicComponents)): 36[polymorphic components](https://prime.haskell.org/wiki/PolymorphicComponents)) -- this
37one is not isomorphic to an existential one:
35 38
36~~~ {.haskell} 39~~~ {.haskell}
37newtype PrinterMethod = PM { unPm :: forall m. MonadResource m => Printout -> m (Maybe PrintingError) } 40newtype PrinterMethod = PM { unPm :: forall m. MonadResource m => Printout -> m (Maybe PrintingError) }
@@ -68,3 +71,128 @@ debugPrint = pure . PM $ const return Nothing <=< liftIO . putStrLn . toString
68toString :: Printout -> String 71toString :: Printout -> String
69toString = undefined 72toString = undefined
70~~~ 73~~~
74
75## Management of Printer Queues
76
77We would like the user to be able to modify the printer queues we maintain in arbitrary
78ways.
79The motivation for this being various cleanup operations such as pruning all successful
80jobs older than a few minutes or limiting the size of history to an arbitrary number of
81entries.
82
83A pattern for this type of modification of a value residing in a `TVar`{.haskell} might
84look like this:
85
86~~~ {.haskell}
87modify :: TVar a -> StateT a STM () -> IO ()
88modify q f = atomically $ writeTVar =<< runStateT f =<< readTVar q
89~~~
90
91A rather natural extension of this is to allow what we will henceforth call a
92`QueueManager`{.haskell} (currently `StateT a STM ()`{.haskell}) to return an indication
93of when it wants to be run again:
94
95~~~ {.haskell}
96type QueueManager = StateT Queue STM Micro
97
98runQM :: QueueManager -> TVar Queue -> IO ()
99runQM qm q = sleep << qm'
100 where
101 qm' = atomically $ (\(a, s) -> a <$ writeTVar q s) =<< runStateT qm =<< readTVar q
102 sleep (abs -> delay) = threadDelay (fromEnum delay) >> runQM qm q
103~~~
104
105It stands to reason that sometimes we don't want to run the `QueueManager`{.haskell} ever
106again (probably causing the thread running it to terminate).
107For doing so we
108[extend the real numbers](https://en.wikipedia.org/wiki/Extended_real_number_line) as
109represented by `Micro`{.haskell} to
110[`Extended Micro`{.haskell}](https://hackage.haskell.org/package/extended-reals):
111
112~~~ {.haskell}
113type QueueManager = StateT Queue STM (Extended Micro)
114
115runQM …
116 where
117
118 sleep (abs -> delay)
119 | (Finite d) <- delay = threadDelay (fromEnum d) >> runQM qm q
120 | otherwise = return ()
121~~~
122
123`QueueManager`{.haskell}s whose type effectively is `Queue -> STM (Queue, Extended Micro)`{.haskell}
124are certainly useful but can carry no state between invocations (which would be useful
125e.g. for limiting the rate at which we prune jobs).
126
127Therefore we allow the user to provide an arbitrary monad functor (we use
128`MFunctor`{.haskell} from
129[mmorph](https://hackage.haskell.org/package/mmorph-1.0.6/docs/Control-Monad-Morph.html#t:MFunctor)
130instead of `Servant.Server.Internal.Enter` because
131[servant-server](https://hackage.haskell.org/package/servant-server-0.4.4.6/docs/Servant-Server-Internal-Enter.html#v:Nat)
132doesn't provide all the tools we require for this) which can carry all the state we could
133ever want:
134
135~~~ {.haskell}
136type QueueManager t = QueueManagerM t (Extended Micro)
137type QueueManagerM t = ComposeT (StateT Queue) t STM -- 'ComposeT' is required since we need 'QueueManagerM' to have the form 't' STM' for some 't'' in order to be able to use 'lift'
138
139runQM :: (MFunctor t, MonadTrans t, MonadIO (t IO), Monad (t STM)) => QueueManager t -> TVar Queue -> t IO ()
140runQM … -- nearly identical except for a sprinkling of 'lift'
141~~~
142
143The final touches are to introduce a typeclass `HasQueue`{.haskell} for convenience:
144
145~~~ {.haskell}
146class HasQueue a where
147 extractQueue :: a -> TVar Queue
148
149instance HasQueue (TVar Queue) where
150 extractQueue = id
151
152instance HasQueue Printer where
153 extractQueue = queue
154~~~
155
156and provide some utility functions for composing `QueueManager`{.haskell}s:
157
158~~~ {.haskell}
159intersection :: (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t
160-- ^ Combine two 'QueueManager's keeping only 'QueueEntry's both managers decide to keep
161--
162-- Side effects propagate left to right
163
164idQM :: Monad (QueueManagerM t) => QueueManager t
165-- ^ Identity of 'intersect'
166
167union :: (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t
168-- ^ Combine two 'QueueManager's keeping all 'QueueEntry's either of the managers decides to keep
169--
170-- Side effects propagate left to right
171
172nullQM :: MonadState Queue (QueueManagerM t) => QueueManager t
173-- ^ Identity of 'union'
174~~~
175
176We merge the effects of two `QueueManager`{.haskell}s by converting the resulting
177`Queue`{.haskell}s to `Set`{.haskell}s and using `Set.union`{.haskell} and
178`Set.intersection`{.haskell} with appropriate `Ord`{.haskell} and `Eq`{.haskell}
179instances.
180
181### Configuration of `QueueManager`{.haskell}s
182
183A `QueueManager`{.haskell}s configuration shall be a `QueueManager t`{.haskell} associated
184with a specification of how to collapse its monad transformer `t`{.haskell}.
185Using universal quantification this is straightforward:
186
187~~~ {.haskell}
188data QMConfig m = forall t. ( MonadTrans t
189 , MFunctor t
190 , Monad (t STM)
191 , MonadIO (t IO)
192 ) => QMConfig { manager :: QueueManager t
193 , collapse :: (t IO) :~> m
194 }
195
196runQM' :: Printer -> QMConfig m -> m ()
197runQM' printer (QMConfig qm nat) = unNat nat $ runQM qm printer
198~~~