summaryrefslogtreecommitdiff
path: root/provider/posts/thermoprint
diff options
context:
space:
mode:
Diffstat (limited to 'provider/posts/thermoprint')
-rw-r--r--provider/posts/thermoprint/1.md130
-rw-r--r--provider/posts/thermoprint/2.lhs262
-rw-r--r--provider/posts/thermoprint/3.lhs92
-rw-r--r--provider/posts/thermoprint/4.md116
-rw-r--r--provider/posts/thermoprint/5.md198
-rw-r--r--provider/posts/thermoprint/6.lhs142
6 files changed, 940 insertions, 0 deletions
diff --git a/provider/posts/thermoprint/1.md b/provider/posts/thermoprint/1.md
new file mode 100644
index 0000000..032e2f6
--- /dev/null
+++ b/provider/posts/thermoprint/1.md
@@ -0,0 +1,130 @@
1---
2title: On the Architecture of a tool-set for interacting with character-oriented printers
3published: 2015-12-25
4tags: Thermoprint
5---
6
7# Motivation
8
9Some time ago I bought a cheap Chinese
10[thermoprinter](https://en.wikipedia.org/wiki/Thermal_printing) off eBay.
11As expected the printers firmware is really awkward to use (including binary
12control codes used to switch between char sets such as bold, italic, underlined,
13etc.).
14The obvious solution was to write a library to parse a more sensible
15representation and send it to be printed.
16
17Since there might, at some point, be other users wanting to print to my
18acquisition the architecture is intended to be present a somewhat usable
19interface to the uninitiated.
20
21# Implementation
22
23## Location
24
25Recently I created a new branch in
26[thermoprint](https://git.yggdrasil.li/thermoprint) called
27[rewrite](https://git.yggdrasil.li/thermoprint?h=rewrite).
28
29## Architecture Overview
30
31The new macroscopic architecture I´m currently aiming for is quite similar to
32the old one:
33
34 * A server intended to run on the machine connected to my cheap printer talking
35 directly to the printer on one end and serving a
36 [json api](https://hackage.haskell.org/package/servant) on the other.
37 * A (hopefully) tiny cli tool for debugging and personal use.
38 * A website (it will probably end up being based on
39 [yesod](https://hackage.haskell.org/package/yesod)) presenting a web interface
40 similar to the cli tool.
41
42## Features
43
44Features I intend to implement include:
45
46 * A parser for a bbcode-dialect which should be used in both the cli tool and the
47 website (it will probably end up using
48 [attoparsec](https://hackage.haskell.org/package/attoparsec)) -- bbcode as
49 presented on [Wikipedia](https://en.wikipedia.org/wiki/BBCode) is a proper
50 superset of the feature-set of my cheap Chinese printer.
51 * Reasonable test coverage using
52 [QuickCheck](https://hackage.haskell.org/package/QuickCheck),
53 [HUnit](http://hackage.haskell.org/package/HUnit).
54
55 Automatic testing with [cabal](https://www.haskell.org/cabal/) facilitated by
56 [hspec](https://hackage.haskell.org/package/hspec).
57 * Support and server-side storage for drafts.
58 * The Website should provide some richer formats than bbcode which will
59 probably find inclusion in the payload datastructure such as lists,
60 checklists, tables, etc.
61
62 The cli-tool should be able to use these too (the input will probably end up
63 being json-formatted).
64
65## Work so far
66
67### Prototype
68
69I already have a prototype.
70It's quite bug-ridden and has recently developed serious problems actually
71printing after working satisfactorily for a few weeks.
72
73It also does not include a web-interface and I am quite unsatisfied with the
74overall code quality.
75
76The [685 lines of code](http://cloc.sourceforge.net/) can be found in the
77[repo](https://git.yggdrasil.li/thermoprint?h=master) as well.
78
79### Rewrite
80
81Currently the [rewrite](https://git.yggdrasil.li/thermoprint?h=rewrite) contains a
82single file of moment -- spec/src/Thermoprint/Printout.hs -- wherein we define
83the payload for the api -- our take on a structured document format (somewhat
84inspired by
85[pandoc](http://hackage.haskell.org/package/pandoc-types/docs/Text-Pandoc-Definition.html)):
86
87~~~ {.haskell}
88-- | A 'Printout' is a sequence of visually seperated 'Paragraph's
89type Printout = Seq Paragraph
90
91-- | A 'Paragraph' is a non-seperated sequence of 'Chunk's
92type Paragraph = Seq Chunk
93
94-- | We introduce both 'Chunk' and 'Paragraph' mainly to allow 'Raw'.
95--
96-- Were we to disallow 'Raw', 'Block' would be identical to 'Paragraph'
97data Chunk = Cooked Block -- ^ text semantically structured to be rendered in accordance with the display format of printer
98 | Raw ByteString -- ^ direct instructions to the printer
99 deriving (Generic, NFData, Show, CoArbitrary)
100
101-- | 'Block' is the entry point for our structured document format
102data Block = Line Line -- ^ a single 'Line' of text
103 | VSpace Integer -- ^ vertical space of height equivalent to 'Integer' lines
104 | NewlSep (Seq Block) -- ^ A sequence of 'Block's seperated by newlines
105 deriving (Generic, NFData, Show, CoArbitrary)
106
107{- | A 'Line' is one of:
108
109 * a single word
110 * horizontal space equivalent to the width of 'Integer' `em`.
111 * a sequence of words seperated by spaces
112
113We don't export all constructors and instead encourage the use of 'text'.
114-}
115data Line = Word Text
116 | HSpace Integer
117 | SpaceSep (Seq Line)
118 deriving (Generic, NFData, Show, CoArbitrary)
119~~~
120
121(The code is verbatim as of 8307d7e).
122
123<!-- LocalWords: Thermoprint thermoprint json api cli yesod bbcode attoparsec
124 -->
125<!-- LocalWords: superset QuickCheck HUnit hspec datastructure repo pandoc
126 -->
127<!-- LocalWords: haskell ByteString NFData CoArbitrary VSpace
128 -->
129<!-- LocalWords: NewlSep HSpace SpaceSep
130 -->
diff --git a/provider/posts/thermoprint/2.lhs b/provider/posts/thermoprint/2.lhs
new file mode 100644
index 0000000..a144fb5
--- /dev/null
+++ b/provider/posts/thermoprint/2.lhs
@@ -0,0 +1,262 @@
1---
2title: On the design of a structured document format compatible with character oriented printers
3published: 2016-01-11
4tags: Thermoprint
5---
6
7This post is an annotated version of the file [spec/src/Thermoprint/Printout.hs](https://git.yggdrasil.li/thermoprint/tree/spec/src/Thermoprint/Printout.hs?h=rewrite&id=f6dc3d1) as of commit `f6dc3d1`.
8
9> {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
10> {-# LANGUAGE OverloadedStrings #-}
11> {-# OPTIONS_HADDOCK show-extensions #-}
12
13Motivation
14----------
15
16We want our codebase to be compatible with as many different models of printers as we are willing to implement.
17It is therefore desirable to maintain a structured document format which we can transform into a printer-specific representation of the payload to be printed with minimal effort.
18
19In this post we present one such format.
20
21Contents
22--------
23
24> -- | This module contains the definition of the structure -- 'Printout' -- used to represent the content of a job
25> module Thermoprint.Printout
26> ( Printout(..)
27> , Paragraph(..)
28> , Chunk(..)
29> , Block(..)
30> , Line( HSpace
31> , SpaceSep
32> )
33> , text, cotext
34> , prop_text
35> ) where
36
37Preliminaries
38-------------
39
40> import Data.Sequence (Seq, (|>), (<|))
41
42A Sequence represents the same structure as the linked lists common in haskell but supports $O(1)$ `snoc`, which is desirable since we intend to iteratively build up the structure when parsing input formats.
43
44> import Data.Text.Lazy (Text)
45>
46> import Data.ByteString.Lazy (ByteString)
47
48The entire structure will be lazy by default but an instance of `NFData`, thus the lazy variants of `Text` and `ByteString`.
49
50> import GHC.Generics (Generic)
51
52We will use derived instances of `Generic` to get handed suitable instances of rather complicated classes such as `Arbitrary` and `FromJSON`
53
54> import Control.DeepSeq (NFData)
55
56Instances of `NFData` allow us to strictly evaluate our document structure when needed
57
58> import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))
59> import qualified Data.Aeson as JSON (encode, decode)
60> import Data.Aeson.Types (typeMismatch)
61
62We will encode the document as a [json](https://en.wikipedia.org/wiki/JSON) object during transport
63
64> import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary, genericShrink)
65> import Test.QuickCheck.Modifiers (NonNegative(..))
66> import Test.QuickCheck.Gen (oneof, suchThat, scale)
67> import Test.QuickCheck.Instances
68> import Test.QuickCheck (forAll, Property)
69
70We will use [QuickCheck](https://hackage.haskell.org/package/QuickCheck) for automatic test generation.
71
72> import qualified Data.Text.Lazy as TL (split, null, pack, filter, intercalate, map)
73> import qualified Data.Text as T (pack)
74> import Data.Char (isSpace)
75>
76> import Data.Monoid (Monoid(..), (<>))
77>
78> import Data.List (dropWhile, dropWhileEnd, groupBy, genericLength, genericReplicate)
79>
80> import Data.Sequence as Seq (fromList, null, singleton)
81>
82> import Data.Function (on)
83>
84> import Data.Foldable (toList, fold)
85
86We will need to do some parsing and pretty-printing to implement `text` and `cotext`, respectively.
87
88> import Data.Encoding (encodeLazyByteStringExplicit, decodeLazyByteString)
89> import Data.Encoding.UTF8
90> import qualified Data.ByteString.Base64.Lazy as Base64 (encode, decode)
91
92Since we want end users to be able to include direct instructions the printer in the form of a lazy [`ByteString`](https://hackage.haskell.org/package/bytestring) we need some way to encode `ByteString`s in JSON.
93We chose [base64](https://hackage.haskell.org/package/base64-bytestring).
94
95> import Prelude hiding (fold)
96>
97>
98> -- | A 'Printout' is a sequence of visually seperated 'Paragraph's
99> type Printout = Seq Paragraph
100
101"visually seperated" will most likely end up meaning "seperated by a single blank line"
102
103> -- | A 'Paragraph' is a non-seperated sequence of 'Chunk's
104> type Paragraph = Seq Chunk
105>
106> -- | We introduce both 'Chunk' and 'Paragraph' mainly to allow 'Raw'.
107> --
108> -- Were we to disallow 'Raw', 'Block' would be identical to 'Paragraph'
109> data Chunk = Cooked Block -- ^ text semantically structured to be rendered in accordance with the display format of printer
110> | Raw ByteString -- ^ direct instructions to the printer
111> deriving (Generic, NFData, Show, CoArbitrary)
112>
113> instance FromJSON Chunk where
114> parseJSON s@(String _) = Raw <$> ((either fail return . decodeBase64) =<< parseJSON s)
115> where
116> decodeBase64 :: String -> Either String ByteString
117> decodeBase64 s = (either (Left . show) Right . encodeLazyByteStringExplicit UTF8Strict $ s) >>= Base64.decode
118> parseJSON o@(Object _) = Cooked <$> parseJSON o
119> parseJSON v = typeMismatch "Chunk" v
120>
121> instance ToJSON Chunk where
122> toJSON (Raw bs) = String . T.pack . decodeLazyByteString UTF8Strict . Base64.encode $ bs
123> toJSON (Cooked block) = toJSON block
124
125We provide custom instances of `FromJSON Chunk` and `ToJSON Chunk` so that we might reduce the sice of the resulting JSON somewhat (this is an opportune target since disambiguaty is simple)
126
127> -- | 'Block' is the entry point for our structured document format
128> data Block = Line Line -- ^ a single 'Line' of text
129> | VSpace Integer -- ^ vertical space of height equivalent to 'Integer' lines
130> | NewlSep (Seq Block) -- ^ A sequence of 'Block's seperated by newlines
131> deriving (Generic, NFData, Show, CoArbitrary, FromJSON, ToJSON)
132>
133> {- | A 'Line' is one of:
134>
135> * a single word
136> * horizontal space equivalent to the width of 'Integer' `em`.
137> * a sequence of words seperated by spaces
138>
139> We don't export all constructors and instead encourage the use of 'text'.
140> -}
141> data Line = Word Text
142> | HSpace Integer
143> | SpaceSep (Seq Line)
144> deriving (Generic, NFData, Show, CoArbitrary, FromJSON, ToJSON)
145>
146> instance Monoid Block where
147> mempty = NewlSep mempty
148> x@(NewlSep xs) `mappend` y@(NewlSep ys)
149> | Seq.null xs = y
150> | Seq.null ys = x
151> | otherwise = NewlSep (xs <> ys)
152> (NewlSep xs) `mappend` y
153> | Seq.null xs = y
154> | otherwise = NewlSep (xs |> y)
155> x `mappend` (NewlSep ys)
156> | Seq.null ys = x
157> | otherwise = NewlSep (x <| ys)
158> x `mappend` y = NewlSep $ Seq.fromList [x, y]
159>
160> instance Monoid Line where
161> mempty = SpaceSep mempty
162> x@(SpaceSep xs) `mappend` y@(SpaceSep ys)
163> | Seq.null xs = y
164> | Seq.null ys = x
165> | otherwise = SpaceSep (xs <> ys)
166> (SpaceSep xs) `mappend` y
167> | Seq.null xs = y
168> | otherwise = SpaceSep (xs |> y)
169> x `mappend` (SpaceSep ys)
170> | Seq.null ys = x
171> | otherwise = SpaceSep (x <| ys)
172> x `mappend` y = SpaceSep $ Seq.fromList [x, y]
173
174The Monoid instances for `Block` and `Line` are somewhat unwieldy since we want to guarantee minimum overhead by reducing expressions such as `SpaceSep (fromList [x])` to `x` whenever possible.
175
176The same effect would have been possible by introducing the monoid structure *one level higher* -- we could have introduced constructors such as `Line :: Seq Word -> Block`.
177This was deemed undesirable since we would not have been able to implement instances such as `Monoid Line` which allow the use of more generic functions during parsing.
178
179> text :: Text -> Either Block Line
180> -- ^ Smart constructor for 'Line'/'Block' which maps word and line boundaries (as determined by 'isSpace' and '(== '\n')' respectively) to the structure of 'Block' and 'Line'.
181> --
182> -- Since we are unwilling to duplicate the list of chars from 'isSpace' we cannot reasonably determine a width for the various whitespace 'Char's.
183> -- Thus they are all weighted equally as having width 1 `em`.
184> text t = case splitLines t of
185> [] -> Right mempty
186> [Line x] -> Right x
187> xs -> Left $ mconcat xs
188> where
189> splitLines :: Text -> [Block]
190> splitLines t = map toBlock
191> . groupBy ((==) `on` TL.null)
192> $ TL.split (== '\n') t
193> splitWords :: Text -> [Line]
194> splitWords t = map toLine
195> . groupBy ((==) `on` TL.null)
196> $ TL.split isSpace t
197> toBlock [] = mempty
198> toBlock xs@(x:_)
199> | TL.null x = VSpace $ genericLength xs - 1
200> | otherwise = mconcat . map (Line . mconcat . splitWords) $ xs
201> toLine [] = mempty
202> toLine xs@(x:_)
203> | TL.null x = HSpace $ genericLength xs - 1
204> | otherwise = mconcat . map Word $ xs
205> list :: b -> (a -> [a] -> b) -> [a] -> b
206> list c _ [] = c
207> list _ f (x:xs) = f x xs
208
209Implementations using `TL.lines` and `TL.words` were tested.
210We chose to use `TL.split`-based solutions instead because the more specific splitting functions provided by [text](https://hackage.haskell.org/package/text) drop information concerning the exact amount of whitespace.
211
212> cotext :: Block -> Text
213> -- ^ inverse of
214> -- @
215> -- either id Line . `text`
216> -- @
217> cotext (VSpace n) = TL.pack . genericReplicate n $ '\n'
218> cotext (NewlSep xs) = TL.intercalate "\n" . map cotext . toList $ xs
219> cotext (Line x) = cotext' x
220> where
221> cotext' (Word x) = x
222> cotext' (HSpace n) = TL.pack . genericReplicate n $ ' '
223> cotext' (SpaceSep xs) = TL.intercalate " " . map cotext' . toList $ xs
224
225We provide cotext for testing `text` and to enable determining semantic equality of `Printout`s at a later date
226
227> prop_text :: Text -> Bool
228> -- ^ prop> (`cotext` . either id Line . `text` $ x) == x
229> --
230> -- Where 'x' is restricted to those `TL.Text` which do not contain whitespace besides ' ' and '\n'.
231> prop_text x = (cotext . either id Line . text $ x') == x'
232> where
233> x' = TL.map normSpace x
234> normSpace c
235> | isSpace c
236> , c `elem` keep = c
237> | isSpace c = ' ' -- We have to do this because all whitespace gets interpreted as width 1
238> | otherwise = c
239> keep = [' ', '\n']
240>
241> -- | We don't test 'Raw' 'Chunk's
242> instance Arbitrary Chunk where
243> shrink = genericShrink
244> arbitrary = Cooked <$> arbitrary
245>
246> instance Arbitrary Block where
247> shrink = genericShrink
248> arbitrary = oneof [ Line <$> arbitrary
249> , VSpace . getNonNegative <$> arbitrary
250> , NewlSep <$> scale' arbitrary
251> ]
252>
253> instance Arbitrary Line where
254> shrink = genericShrink
255> arbitrary = oneof [ Word . TL.filter (not . isSpace) <$> arbitrary -- 'isSpace '\n' == True'
256> , HSpace . getNonNegative <$> arbitrary
257> , SpaceSep <$> scale' arbitrary
258> ]
259>
260> scale' = scale (round . sqrt . fromInteger . toInteger)
261
262Failing to properly scale the tested structures was shown to use more than 8GiB of RAM during testing
diff --git a/provider/posts/thermoprint/3.lhs b/provider/posts/thermoprint/3.lhs
new file mode 100644
index 0000000..5e7eee9
--- /dev/null
+++ b/provider/posts/thermoprint/3.lhs
@@ -0,0 +1,92 @@
1---
2title: Thoughts on a network protocol for a toolset for interacting with character-oriented printers
3published: 2016-01-11
4tags: Thermoprint
5---
6
7This post is an annotated version of the file [spec/src/Thermoprint/API.hs](https://git.yggdrasil.li/thermoprint/tree/spec/src/Thermoprint/API.hs?h=rewrite&id=3ad700c) as of commit `3ad700c`.
8
9> {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
10> {-# LANGUAGE TypeOperators, DataKinds #-}
11> {-# LANGUAGE OverloadedStrings #-}
12>
13> module Thermoprint.API
14> ( PrinterStatus(..)
15> , JobStatus(..)
16> , ThermoprintAPI
17> , thermoprintAPI
18> , module Thermoprint.Identifiers
19> , module Thermoprint.Printout
20> ) where
21>
22> import Thermoprint.Printout
23
24See [a previous post](https://dirty-haskell.org/posts/thermoprint-2.html).
25
26> import Thermoprint.Identifiers
27
28`Thermoprint.Identifiers` provides some newtypes of `Integer` to add some typesafety to dealing with objects identified by autoincremented numbers
29
30> import Servant.API
31> import Servant.Docs
32> import Data.Aeson
33
34We will define our API to be compatible with [servant](https://hackage.haskell.org/package/servant)
35
36> import Data.Set (Set)
37> import Data.Sequence (Seq)
38
39Higher performance versions of lists for our various applications
40
41> import GHC.Generics (Generic)
42>
43> import Data.Proxy (Proxy(..))
44>
45> import Control.Exception (Exception)
46> import Data.Typeable (Typeable)
47>
48> data PrinterStatus = Busy JobId
49> | Available
50> deriving (Generic, Show, FromJSON, ToJSON)
51>
52> data JobStatus = Queued
53> | Printing
54> | Done
55> | Failed PrintingError
56> deriving (Generic, Show, FromJSON, ToJSON)
57>
58> data PrintingError = UnknownError
59> deriving (Typeable, Generic, Show, FromJSON, ToJSON, Exception)
60
61We expect the definiton of `PrintingError` to grow considerably while implementing a server for this API
62
63We support the following actions through our API:
64
65> type ThermoprintAPI = "printers" :> Get '[JSON] (Set PrinterId) -- List the identifiers of all available printers (/printers)
66> :<|> "printer" :> Capture "printerId" PrinterId :> (
67> ReqBody '[JSON] Printout :> Post '[JSON] JobId -- Add a new job to the bottom of the queue by sending its content (/printer:printerId)
68> :<|> "status" :> Get '[JSON] PrinterStatus -- Query the current status of a printer (/printer:printerId/status)
69> )
70> :<|> "jobs" :> (
71> QueryParam "printer" PrinterId :> QueryParam "min" JobId :> QueryParam "max" JobId :> Get '[JSON] (Seq JobId) -- List all jobs allowing for selection by printerId and pagination (/jobs?printer=*&min=*&max=*)
72> )
73> :<|> "job" :> Capture "jobId" JobId :> (
74> Get '[JSON] Printout -- Get the contents of a job currently known to the server (/job:jobId)
75> :<|> "status" :> Get '[JSON] JobStatus -- Get the status of a job (/job:jobId/status)
76> :<|> "printer" :> Get '[JSON] PrinterId -- Find the printer a job was queued for (/job:jobId/printer)
77> :<|> Delete '[] () -- Abort a job (which we expect to make it unknown to the server) (/job:jobId)
78> )
79> :<|> "drafts" :> (
80> Get '[JSON] (Set DraftId) -- List the identifiers of all drafts known to the server (/drafts)
81> :<|> ReqBody '[JSON] Printout :> Post '[JSON] DraftId -- Make a draft known to the server by submitting its contents (/drafts)
82> )
83> :<|> "draft" :> Capture "draftId" DraftId :> (
84> ReqBody '[JSON] Printout :> Put '[] () -- Update a draft by replacing its contents (/draft:draftId)
85> :<|> Get '[JSON] Printout -- Get the contents of a draft (/draft:draftId)
86> :<|> Delete '[] () -- Delete a draft (/draft:draftId)
87> )
88>
89> thermoprintAPI :: Proxy ThermoprintAPI
90> thermoprintAPI = Proxy
91
92servant needs an object of type `Proxy ThermoprintAPI` in various places
diff --git a/provider/posts/thermoprint/4.md b/provider/posts/thermoprint/4.md
new file mode 100644
index 0000000..756c166
--- /dev/null
+++ b/provider/posts/thermoprint/4.md
@@ -0,0 +1,116 @@
1---
2title: On the Design of a Parser
3published: 2016-01-12
4tags: Thermoprint
5---
6
7The concrete application we’ll be walking through is a naive parser for [bbcode](https://en.wikipedia.org/wiki/BBCode)
8-- more specifically the contents of the directory `bbcode` in the
9[git repo](https://git.yggdrasil.li/thermoprint/tree/bbcode?h=rewrite&id=dc99dae).
10
11In a manner consistent with designing software as
12[compositions of simple morphisms](https://en.wikipedia.org/wiki/Tacit_programming) we start by determining the type of
13our solution (as illustrated by the following mockup):
14
15~~~ {.haskell}
16-- | Our target structure -- a rose tree with an explicit terminal constructor
17data DomTree = Element Text (Map Text Text) [DomTree]
18 | Content Text
19 deriving (Show, Eq)
20
21bbcode :: Text -> Maybe DomTree
22-- ^ Parse BBCode
23~~~
24
25Writing a parser capable of dealing with `Text` directly from scratch would be unnecessarily abstruse, we’ll be using
26the [attoparsec](https://hackage.haskell.org/package/attoparsec/docs/Data-Attoparsec-Text.html) family of parser
27combinators instead.
28
29We reproduce an incomplete version of the lexer below (it’s missing tag attributes and self-closing tags).
30
31We introduce `escapedText`, a helper function for extracting text until we reach one of a set of delimiting characters
32(exclusive).
33While doing this we also parse any delimiting character iff it's prefixed with an escape character (we use `\`) -- the
34escape character itself needs only be escaped if encountered directly before one of the delimiting characters.
35
36~~~ {.haskell}
37data Token = BBOpen Text -- ^ "[open]"
38 | BBClose Text -- ^ "[/close]"
39 | BBStr Text -- ^ "text"
40
41token :: Parser [Token]
42token = BBClose <$ "[/" <*> escapedText' [']'] <* "]"
43 <|> BBOpen <$ "[" <*> escapedText' [']'] <* "]"
44 <|> BBStr <$> escapedText ['[']
45
46escapedText' :: [Char] -> Parser Text
47escapedText' = option "" . escapedText
48
49escapedText :: [Char] -> Parser Text
50escapedText [] = takeText -- No delimiting characters -- parse all remaining input
51escapedText cs = recurse $ choice [ takeWhile1 (not . special) -- a series of characters we don't treat as special
52 , escapeSeq -- an escaped delimiter
53 , escapeChar' -- the escape character
54 ]
55 where
56 escapeChar = '\\'
57 special = inClass $ escapeChar : cs
58 escapeChar' = string $ T.singleton escapeChar
59 escapeSeq = escapeChar' *> (T.singleton <$> satisfy special) -- escape character followed by a special character (which encludes the escape character)
60 recurse p = mappend <$> p <*> escapedText' cs -- parse a prefix and optionally append another chunk of escapedText
61
62runTokenizer :: Text -> Maybe [Token]
63runTokenizer = either (const Nothing) Just . parseOnly (many token <* endOfInput)
64~~~
65
66We have now reduced the Problem to `[Token] -> DomTree`.
67We quickly see that the structure of the problem is that of a
68[fold](https://hackage.haskell.org/package/base/docs/Data-Foldable.html).
69
70Having realised this we require a function of type `Token -> DomTree -> DomTree` to recursively build up our target
71structure.
72
73In general we’ll want to not only keep track of the `DomTree` during recursion but also maintain a reference to the
74position at which we’ll be inserting new tokens.
75This kind of problem is well understood and solved idiomatically by using a
76[zipper](https://en.wikipedia.org/wiki/Zipper_(data_structure))
77([a cursory introduction](http://learnyouahaskell.com/zippers)).
78
79Writing zippers tends to be tedious. We’ll therefore introduce an
80[additional intermediate structure](https://hackage.haskell.org/package/containers/docs/Data-Tree.html) for which an
81[implementation](https://hackage.haskell.org/package/rosezipper) is available readily.
82The morphism from this new structure (`Forest BBLabel`) to our `DomTree` will be almost trivial.
83
84~~~ {.haskell}
85import Data.Tree.Zipper (TreePos, Empty, Full)
86import qualified Data.Tree.Zipper as Z
87
88data BBLabel = BBTag Text
89 | BBPlain Text
90
91rose :: [BBToken] -> Maybe (Forest BBLabel)
92rose = Z.toForest <$> foldM (flip rose') (Z.fromForest [])
93
94rose' :: BBToken -> TreePos Empty BBLabel -> Maybe (TreePos Empty BBLabel)
95rose' (BBStr t) = return . Z.nextSpace . Z.insert (Node (BBPlain t) []) -- insert a node with no children and move one step to the right in the forest we’re currently viewing
96rose' (BBOpen t) = return . Z.children . Z.insert (Node (BBTag t) []) -- insert the node and move into position to insert it's first child
97rose' (BBClose t) = close t -- haskell complains if multiple equations for the same function have a differing number of arguments, therefore: 'close'
98 where
99 close :: Text -> TreePos Empty BBLabel -> Maybe (TreePos Empty BBLabel)
100 close tag pos = do
101 pos' <- Z.parent pos -- fail if we're trying to close a tag that does not have a parent (this indicates imbalanced tags)
102 let
103 pTag = (\(BBTag t) -> t) $ Z.label pos' -- yes, this will fail unceremoniously if the parent is not a tag, this poses no problem since we're constructing the structure ourselves. The proof that this failure mode does not occur is left as an exercise for the reader.
104 guard (pTag == tag) -- The structure shows that this mode of failure (opening tags content does not match the closing tags) is not logically required -- it only serves as a *notification* to the user
105 return $ Z.nextSpace pos' -- move one level up and to point at the next sibling of the parent
106~~~
107
108All that is left to do now is present our final morphism:
109
110~~~ {.haskell}
111dom :: Forest BBLabel -> [DomTree]
112dom = map dom'
113 where
114 dom' (Node (BBPlain t) []) = Content t
115 dom' (Node (BBTag t) ts = Element t $ map dom' ts
116~~~
diff --git a/provider/posts/thermoprint/5.md b/provider/posts/thermoprint/5.md
new file mode 100644
index 0000000..0249734
--- /dev/null
+++ b/provider/posts/thermoprint/5.md
@@ -0,0 +1,198 @@
1---
2title: Building an Extensible Framework for Specifying Compile-Time Configuration using Universal Quantification
3tags: Thermoprint
4published: 2016-02-18
5---
6
7When I write *Universal Quantification* I mean what is commonly referred to as
8[existential quantification](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/data-type-extensions.html#existential-quantification),
9which I think is a misnomer. To wit:
10
11$( \exists x \ldotp f(x) ) \to y$ is isomorphic to $\forall x \ldotp (f(x) \to y)$ (I
12won´t try to back this claim up with actual category theory just now. You might want to
13nag me occasionally if this bothers you -- I really should invest some more time into
14category theory). Since haskell does not support `exists` we´re required to use the
15`forall`-version, which really is universally quantified.
16
17## Printer Configuration
18
19What we want is to have the user provide us with a set of specifications of how to
20interact with one printer each.
21Something like the following:
22
23~~~ {.haskell}
24newtype PrinterMethod = PM { unPM :: Printout -> IO (Maybe PrintingError) }
25
26data Printer = Printer
27 { print :: PrinterMethod
28 , queue :: TVar Queue
29 }
30~~~
31
32The first step in refining this is necessitated by having the user provide the
33[monad-transformer-stack](http://book.realworldhaskell.org/read/monad-transformers.html)
34to use at compile time.
35Thus we introduce our first universal quantification (in conjunction with
36[polymorphic components](https://prime.haskell.org/wiki/PolymorphicComponents)) -- this
37one is not isomorphic to an existential one:
38
39~~~ {.haskell}
40newtype PrinterMethod = PM { unPm :: forall m. MonadResource m => Printout -> m (Maybe PrintingError) }
41~~~
42
43Since we don´t want to *burden* the user with the details of setting up `TVar Queue`{.haskell} we
44also introduce function to help with that:
45
46~~~ {.haskell}
47printer :: MonadResource m => PrinterMethod -> m Printer
48printer p = Printer p <$> liftIO (newTVarIO def)
49~~~
50
51We could at this point provide ways to set up `PrinterMethod`{.haskell}s and have the user
52provide us with a list of them.
53
54We, however, have numerous examples of printers which require some setup (such opening a
55file descriptor). The idiomatic way to handle this is to decorate that setup with some
56constraints and construct our list of printers in an
57[`Applicative`{.haskell}](https://hackage.haskell.org/package/base/docs/Control-Applicative.html#t:Applicative)
58fashion:
59
60~~~ {.haskell}
61printer :: MonadResource m => m PrinterMethod -> m Printer
62printer p = Printer <$> p <*> liftIO (newTVarIO def)
63~~~
64
65At this point a toy implementation of a printer we might provide looks like this:
66
67~~~ {.haskell}
68debugPrint :: Applicative m => m PrinterMethod
69debugPrint = pure . PM $ const return Nothing <=< liftIO . putStrLn . toString
70
71toString :: Printout -> String
72toString = undefined
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~~~
diff --git a/provider/posts/thermoprint/6.lhs b/provider/posts/thermoprint/6.lhs
new file mode 100644
index 0000000..9182427
--- /dev/null
+++ b/provider/posts/thermoprint/6.lhs
@@ -0,0 +1,142 @@
1---
2title: Deriving a Client Library for Interacting with Character-Oriented Printers
3tags: Thermoprint
4published: 2016-02-18
5---
6
7> {-# LANGUAGE DataKinds #-}
8> {-# LANGUAGE TypeOperators #-}
9> {-# LANGUAGE ViewPatterns #-}
10> {-# LANGUAGE RecordWildCards #-}
11>
12> -- | A client library for 'Thermoprint.API'
13> module Thermoprint.Client
14> ( Client(..)
15> , mkClient, mkClient'
16> , throwNat, ioNat
17> -- = Reexports
18> , ServantError(..)
19> , module Servant.Common.BaseUrl
20> , module Control.Monad.Trans.Either
21> , module Servant.Server.Internal.Enter
22> ) where
23>
24> import Thermoprint.API
25> import Data.Map (Map)
26> import Data.Sequence (Seq)
27> import Data.Time (UTCTime)
28>
29> import Servant.Client hiding (HasClient(..))
30> import qualified Servant.Client as S
31> import Servant.Common.BaseUrl
32> import Servant.API
33> import Servant.Server.Internal.Enter
34> import Control.Monad.Trans.Either
35>
36> import Control.Monad.Catch (Exception, MonadThrow(..))
37> import Control.Monad.IO.Class (MonadIO(..))
38>
39> import Control.Monad
40> import Control.Category
41> import Prelude hiding (id, (.))
42>
43> instance Exception ServantError
44
45We encapsulate all api operations in a single record parametrized over the monad we intend to use
46them in.
47Construction of such a record is pure since all we require to do so is a `BaseUrl`{.haskell}.
48Using RecordWildCards we can bring all operations into scope with extreme ease.
49
50> -- | All 'ThermoprintAPI'-functions as a record
51> --
52> -- Use like this:
53> --
54> -- > {-# LANGUAGE RecordWildCards #-}
55> -- >
56> -- > main :: IO ()
57> -- > -- ^ Display a list of printers with their status
58> -- > main = print =<< printers
59> -- > where Client{..} = mkClient' $ Http "localhost" 3000
60> data Client m = Client
61> { printers :: m (Map PrinterId PrinterStatus)
62> -- ^ List all printers
63> , jobs :: Maybe PrinterId
64> -> Maybe (Range (JobId))
65> -> Maybe (Range (UTCTime))
66> -> m (Seq (JobId, UTCTime, JobStatus))
67> -- ^ List a selection of jobs
68> , jobCreate :: Maybe PrinterId -> Printout -> m JobId
69> -- ^ Send a 'Printout' to be queued
70> , job :: JobId -> m Printout
71> -- ^ Retrieve the contents of a job
72> , jobStatus :: JobId -> m JobStatus
73> -- ^ Query a jobs status
74> , jobDelete :: JobId -> m ()
75> -- ^ Delete a job from the queue (not from history or while it is being printed)
76> , drafts :: m (Map DraftId (Maybe DraftTitle))
77> -- ^ List all saved drafts
78> , draftCreate :: Maybe DraftTitle
79> -> Printout
80> -> m DraftId
81> -- ^ Create a new draft
82> , draftReplace :: DraftId
83> -> Maybe DraftTitle
84> -> Printout
85> -> m ()
86> -- ^ Replace the contents and title of an existing draft
87> , draft :: DraftId -> m (Maybe DraftTitle, Printout)
88> -- ^ Retrieve the contents and title of a draft
89> , draftDelete :: DraftId -> m ()
90> -- ^ Delete a draft
91> , draftPrint :: DraftId -> Maybe PrinterId -> m JobId
92> -- ^ Send a draft to be printed
93> }
94
95[servant documentation](https://haskell-servant.github.io/tutorial/server.html#nested-apis)
96advises factoring out apis to make the specification more concise.
97We are rightly advised that doing so has an effect on the types of the
98corresponding `Server`{.haskell}s and `Client`{.haskell}s.
99To cope with this we introduce a helper function that allows us, when
100used with ViewPatterns, to nontheless simply pattern match on `client`{.haskell}.
101
102> withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b))
103> -- ^ Undo factoring of APIs
104> withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI
105
106`withArgs`{.haskell} as presented here does not recurse and thus
107doesn't handle more than one occurence of `:<|>`{.haskell}.
108We have to to so ourselves using nested ViewPatterns (see
109`mkClient`{.haskell}).
110
111> mkClient :: (EitherT ServantError IO :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors
112> -> BaseUrl
113> -> Client m
114> -- ^ Generate a 'Client'
115
116RecordWildCards also allows us to construct a record from components
117in scope.
118
119> mkClient n url = Client{..}
120> where
121> printers
122> :<|> (jobs :<|> jobCreate)
123> :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete))
124> :<|> (drafts :<|> draftCreate)
125> :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint)))
126> = enter n $ client thermoprintAPI url
127
128We also provide some additional convenience functions so the user
129doesn't have to construct their own `Nat`{.haskell}ural
130transformations.
131
132> mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m
133> -- ^ @mkClient' = mkClient $ ioNat . throwNat@
134> mkClient' = mkClient $ ioNat . throwNat
135>
136> throwNat :: (Exception e, MonadThrow m) => EitherT e m :~> m
137> -- ^ Squash a layer of 'EitherT' into the underlying monad supporting 'throwM'
138> throwNat = Nat $ either throwM return <=< runEitherT
139>
140> ioNat :: MonadIO m => IO :~> m
141> -- ^ @ioNat = Nat liftIO@
142> ioNat = Nat liftIO
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-24 20:05:21 +0000