28 Sep 2021

Using lens to set a value based on another

I started writing a small tool for work that consumes YAML files and combines the data into a single YAML file. To be specific it consumes YAML files containing snippets of service specification for Docker Compose and it produces a YAML file for use with docker-compose. Besides being useful to me, I thought it'd also be a good way to get some experience with lens.

The first transformation I wanted to write was one that puts in the correct image name. So, only slightly simplified, it is transforming

panda:
    x-image: panda
goat:
    x-image: goat
tapir:
    image: incorrent
    x-image: tapir

into

panda:
    image: panda:latest
    x-image: panda
goat:
    image: goat:latest
    x-image: goat
tapir:
    image: tapir:latest
    x-image: tapir

That is, it creates a new key/value pair in each object based on the value of x-image in the same object.

First approach

The first approach I came up with was to traverse the sub-objects and apply a function that adds the image key.

setImage :: Value -> Value
setImage y = y & members %~ setImg
  where
    setImg o =
        o
            & _Object . at "image"
            ?~ String (o ^. key "x-image" . _String <> ":latest")

It did make me wonder if this kind of problem, setting a value based on another value, isn't so common that there's a nicer solution to it. Perhaps coded up in a combinator that isn't mentioned in Optics By Example (or mabye I've forgot it was mentioned). That lead me to ask around a bit, which leads to approach two.

Second approach

Arguably there isn't much difference, it's still traversing the sub-objects and applying a function. The function makes use of view being run in a monad and ASetter being defined with Identity (a monad).

setImage' :: Value -> Value
setImage' y =
    y
        & members . _Object
        %~ (set (at "image") . (_Just . _String %~ (<> ":latest")) =<< view (at "x-image"))

I haven't made up my mind on whether I like this better than the first. It's disappointingly similar to the first one.

Third approach

Then I it might be nice to split the fetching of x-image values from the addition of image key/value pairs. By extracting with an index it's possible to keep track of what sub-object each x-image value comes from. Then two steps can be combined using foldl.

setImage'' :: Value -> Value
setImage'' y = foldl setOne y vals
  where
    vals = y ^@.. members <. key "x-image" . _String
    setOne y' (objKey, value) =
        y'
            & key objKey . _Object . at "image"
            ?~ String (value <> ":latest")

I'm not convinced though. I guess I'm still holding out for a brilliant combinator that fits my problem perfectly.

Please point me to "the perfect solution" if you have one, or if you just have some general tips on optics that would make my code clearer, or shorter, or more elegant, or maybe just more lens-y.

Tags: haskell lens optics
23 Jul 2021

Keeping todo items in org-roam v2

Org-roam v2 has been released and yes, it broke my config a bit. Unfortunately the v1-to-v2 upgrade wizard didn't work for me. I realized later that it might have been due to the roam-related functions I'd hooked into `'before-save-hook`. I didn't think about it until I'd already manually touched up almost all my files (there aren't that many) so I can't say anything for sure. However, I think it might be a good idea to keep hooks in mind if one runs into issues with upgrading.

The majority of the time I didn't spend on my notes though, but on the setup I've written about in an earlier post, Keeping todo items in org-roam. Due to some of the changes in v2, changes that I think make org-roam slightly more "org-y", that setup needed a bit of love.

The basis is still the same 4 functions I described in that post, only the details had to be changed.

I hope the following is useful, and as always I'm always happy to receive commends and suggestions for improvements.

Some tag helpers

The very handy functions for extracting tags as lists seem to be gone, in their place I found org-roam-{get,set}-keyword. Using these I wrote three wrappers that allow slightly nicer handling of tags.

(defun roam-extra:get-filetags ()
  (split-string (or (org-roam-get-keyword "filetags") "")))

(defun roam-extra:add-filetag (tag)
  (let* ((new-tags (cons tag (roam-extra:get-filetags)))
         (new-tags-str (combine-and-quote-strings new-tags)))
    (org-roam-set-keyword "filetags" new-tags-str)))

(defun roam-extra:del-filetag (tag)
  (let* ((new-tags (seq-difference (roam-extra:get-filetags) `(,tag)))
         (new-tags-str (combine-and-quote-strings new-tags)))
    (org-roam-set-keyword "filetags" new-tags-str)))

The layer

roam-extra:todo-p needed no changes at all. I'm including it here only for easy reference.

(defun roam-extra:todo-p ()
  "Return non-nil if current buffer has any TODO entry.

TODO entries marked as done are ignored, meaning the this
function returns nil if current buffer contains only completed
tasks."
  (org-element-map
      (org-element-parse-buffer 'headline)
      'headline
    (lambda (h)
      (eq (org-element-property :todo-type h)
          'todo))
    nil 'first-match))

As pretty much all functions I used in the old version of roam-extra:update-todo-tag are gone I took the opportunity to rework it completely. I think it ended up being slightly simpler. I suspect the the use of org-with-point-at 1 ... is unnecessary, but I haven't tested it yet so I'm leaving it in for now.

(defun roam-extra:update-todo-tag ()
  "Update TODO tag in the current buffer."
  (when (and (not (active-minibuffer-window))
             (org-roam-file-p))
    (org-with-point-at 1
      (let* ((tags (roam-extra:get-filetags))
             (is-todo (roam-extra:todo-p)))
        (cond ((and is-todo (not (seq-contains-p tags "todo")))
               (roam-extra:add-filetag "todo"))
              ((and (not is-todo) (seq-contains-p tags "todo"))
               (roam-extra:del-filetag "todo")))))))

In the previous version roam-extra:todo-files was built using an SQL query. That felt a little brittle to me, so despite that my original inspiration contains an updated SQL query I decided to go the route of using the org-roam API instead. The function org-roam-node-list makes it easy to get all nodes and then finding the files is just a matter of using seq-filter and seq-map. Now that headings may be nodes, and that heading-based nodes seem to inherit the top-level tags, a file may appear more than once, hence the call to seq-unique at the end.

Based on what I've seen V2 appears less eager to sync the DB, so to make sure all nodes are up-to-date it's best to start off with forcing a sync.

(defun roam-extra:todo-files ()
  "Return a list of roam files containing todo tag."
  (org-roam-db-sync)
  (let ((todo-nodes (seq-filter (lambda (n)
                                  (seq-contains-p (org-roam-node-tags n) "todo"))
                                 (org-roam-node-list))))
    (seq-uniq (seq-map #'org-roam-node-file todo-nodes))))

With that in place it turns out that also roam-extra:update-todo-files worked without any changes. I'm including it here for easy reference as well.

(defun roam-extra:update-todo-files (&rest _)
  "Update the value of `org-agenda-files'."
  (setq org-agenda-files (roam-extra:todo-files)))

Hooking it up

The variable org-roam-file-setup-hook is gone, so the the more general find-file-hook will have to be used instead.

(add-hook 'find-file-hook #'roam-extra:update-todo-tag)
(add-hook 'before-save-hook #'roam-extra:update-todo-tag)
(advice-add 'org-agenda :before #'roam-extra:update-todo-files)
Tags: emacs org-mode org-roam spacemacs
03 Jul 2021

The timeout manager exception

The other day I bumped the dependencies of a Haskell project at work and noticed a new exception being thrown:

Thread killed by timeout manager

After a couple of false starts (it wasn't the connection pool, nor was it servant) I realised that a better approach would be to look at the list of packages that were updated as part of the dependency bumping.1 Most of them I thought would be very unlikely sources of it, but two in the list stood out:

Package Pre Post
unliftio 0.2.14 0.2.18
warp 3.3.15 3.3.16

warp since the exception seemed to be thrown shortly after handling an HTTP request, and unliftio since the exception was caught by the handler for uncaught exceptions and its description contains "thread". Also, when looking at the code changes in warp on GitHub2 I found that some of the changes introduced was increased use of unliftio for async stuff. The changes contain mentions of TimeoutThread and System.TimeManager. That sounded promising, and it lead me to the TimeoutThread exception in time-manager.

With that knowledge I could quickly adjust the handler for uncaught exceptions to not log TimeoutThread as fatal:

lastExceptionHandler :: LoggerSet -> SomeException -> IO ()
lastExceptionHandler logger e
  | Just TimeoutThread <- fromException e = return ()
  | otherwise = do
      logFatalIoS logger $ pack $ "uncaught exception: " <> displayException e
      flushLogStr logger

I have to say it was a bit more work to arrive at this than I'd have liked. I reckon there are easier ways to track down the information I needed. So I'd love to hear what tricks and tips others have.

Footnotes:

1

As a bonus it gave me a good reason to reach for comm, a command that I rarely use but for some reason always enjoy.

2

GitHub's compare feature isn't very easy to discover, but a URL like this https://github.com/yesodweb/wai/compare/warp-3.3.15…warp-3.3.16 (note the 3 dots!) does the trick.

Tags: haskell warp servant
27 Jun 2021

A first look at HMock

The other day I found Chris Smith's HMock: First Rate Mocks in Haskell (link to hackage) and thought it could be nice see if it can clear up some of the tests I have in a few of the Haskell projects at work. All the projects follow the pattern of defining custom monads for effects (something like final tagless) with instances implemented on a stack of monads from MTL. It's a pretty standard thing in Haskell I'd say, especially since the monad stack very often ends up being ReaderT MyConfig IO.

I decided to try it first on a single such custom monad, one for making HTTP requests:

class Monad m => MonadHttpClient m where
  mHttpGet :: String -> m (Status, ByteString)
  mHttpPost :: (Typeable a, Postable a) => String -> a -> m (Status, ByteString)

Yes, the underlying implementation uses wreq, but I'm not too bothered by that shining through. Also, initially I didn't have that Typeable a constraint on mHttpPost, it got added after a short exchange about KnownSymbol with Chris.

To dip a toe in the water I thought I'd simply write tests for the two effects themselves. First of all there's an impressive list of extensions needed, and then the monad needs to be made mockable:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

makeMockable ''MonadHttpClient

After that, writing a test with HMock for mHttpGet was fairly straight forward, I could simply follow the examples in the package's documentation. I'm using tasty for organising the tests though:

httpGetTest :: TestTree
httpGetTest = testCase "Get" $ do
  (s, b) <- runMockT $ do
    expect $ MHttpGet "url" |-> (status200, "result")
    mHttpGet "url"
  status200 @=? s
  "result" @=? b

The effect for sending a POST request was slightly trickier, as can be seen in the issue linked above, but with some help I came up with the following:

httpPostTest :: TestTree
httpPostTest = testCase "Post" $ do
  (s, b) <- runMockT $ do
    expect $ MHttpPost_ (eq "url") (typed @ByteString anything) |-> (status201, "result")
    mHttpPost "url" ("hello" :: ByteString)
  status201 @=? s
  "result" @=? b

Next step

My hope is that using HMock will remove the need for creating a bunch of test implementations for the various custom monads for effects1 in the projects, thereby reducing the amount of test code overall. I also suspect that it will make the tests clearer and easier to read, as the behaviour of the mocks are closer to the tests using the mocks.

Footnotes:

1

Basically they could be looked at as hand-written mocks.

Tags: haskell testing mocks
06 Jun 2021

ZSH, Nix, and completions

TIL that ZSH completions that come with Nix packages end up in ~/.nix-profile/share/zsh/vendor-completions/ and that folder is not added to $FPATH by the init script that comes with Nix.

After modifying the bit in ~/.zshenv it now looks like this

if [[ -f ~/.nix-profile/etc/profile.d/nix.sh ]]; then
    source ~/.nix-profile/etc/profile.d/nix.sh
    export fpath=(~/.nix-profile/share/zsh/vendor-completions ${fpath})
fi
Tags: nix zsh
Other posts