13 Apr 2021

Nix shell, direnv and XDG_DATA_DIRS

A few weeks ago I noticed that I no longer could use haskell-hoogle-lookup-from-website in Emacs. After a bit of experimentation I found that the reason was that I couldn't use xdg-open in a Nix shell. Yesterday I finally got around to look into further.

It's caused by direnv overwriting XDG_DATA_DIRS rather than appending to it. Of course someone already reported a bug already.

The workaround is to use

use nix --keep XDG_DATA_DIRS
Tags: nix direnv
21 Mar 2021

Todo items in org-roam, an update

I got an email from Mr Z with a nice modification to the code in my post on keeping todo items in org-roam.

He already had a bunch of agenda files that he wanted to keep using (I had so few of them that I'd simply converted them to roam files). Here's the solution he shared with me:

(defvar roam-extra-original-org-agenda-files nil
  "Original value of  `org-agenda-files'.")

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

It's a rather nice modification I think. Thanks to Mr Z for agreeing to let me share it here.

Tags: emacs org-mode org-roam
20 Mar 2021

Barbie and KenJSON

After higher-kinded data (HKD) and barbies were mentioned in episode 35 of Haskell Weekly I've been wondering if it could be used in combination with aeson to do validation when implementing web services.

TLDR; I think it'd work, but I have a feeling I'd have to spend some more time on it to get an API with nice ergonomics.

Defining a type to play with

I opted to use barbies-th to save on the typing a bit. Defining a simple type holding a name and an age can then look like this

declareBareB
  [d|
   data Person = Person {name :: Text, age :: Int}
  |]

deriving instance Show (Person Covered Identity)
deriving instance Show (Person Covered Maybe)
deriving instance Show (Person Covered (Either Text))

The two functions from the Barbies module documentation, addDefaults and check, can then be written like this

addDefaults :: Person Covered Maybe -> Person Covered Identity -> Person Covered Identity
addDefaults = bzipWith trans
  where
    trans m d = maybe d pure m

check :: Person Covered (Either Text) -> Either [Text] (Person Covered Identity)
check pe = case btraverse (either (const Nothing) (Just . Identity)) pe of
  Just pin -> Right pin
  Nothing -> Left $ bfoldMap (either (: []) (const [])) pe

I found it straight forward to define some instances and play with those functions a bit.

Adding in JSON

The bit that wasn't immediately obvious to me was how to use aeson to parse into a type like Person Covered (Either Text).

First off I needed some data to test things out with.

bs0, bs1 :: BSL.ByteString
bs0 = "{\"name\": \"the name\", \"age\": 17}"
bs1 = "{\"name\": \"the name\", \"age\": true}"

To keep things simple I took baby steps, first I tried parsing into Person Covered Identity. It turns out that the FromJSON instance from that doesn't need much thought at all. (It's a bit of a pain to have to specify types in GHCi all the time, so I'm throwing in a specialised decoding function for each type too.)

instance FromJSON (Person Covered Identity) where
  parseJSON = withObject "Person" $
    \o -> Person <$> o .: "name"
      <*> o .: "age"

decodePI :: BSL.ByteString -> Maybe (Person Covered Identity)
decodePI = decode

Trying it out on the test data gives the expected results

λ> let i0 = decodePI bs0
λ> i0
Just (Person {name = Identity "the name", age = Identity 17})
λ> let i1 = decodePI bs1
λ> i1
Nothing

So far so good! Moving onto Person Covered Maybe. I spent some time trying to use the combinators in Data.Aeson for dealing with parser failures, but in the end I had to resort to using <|> from Alternative.

instance FromJSON (Person Covered Maybe) where
  parseJSON = withObject "Person" $
    \o -> Person <$> (o .: "name" <|> pure Nothing)
      <*> (o .: "age" <|> pure Nothing)

decodePM :: BSL.ByteString -> Maybe (Person Covered Maybe)
decodePM = decode

Trying that out I saw exactly the behaviour I expected, i.e. that parsing won't fail. (Well, at least not as long as it's a valid JSON object to being with.)

λ> let m0 = decodePM bs0
λ> m0
Just (Person {name = Just "the name", age = Just 17})
λ> let m1 = decodePM bs1
λ> m1
Just (Person {name = Just "the name", age = Nothing})

With that done I found that the instance for Person Covered (Either Text) followed quite naturally. I had to spend a little time on getting the types right to parse the fields properly. Somewhat disappointingly I didn't get type errors when the behaviour of the code turned out to be wrong. I'm gussing aeson's Parser was a little too willing to give me parser failures. Anyway, I ended up with this instance

instance FromJSON (Person Covered (Either Text)) where
  parseJSON = withObject "Person" $
    \o -> Person <$> ((Right <$> o .: "name") <|> pure (Left "A name is most needed"))
      <*> ((Right <$> o .: "age") <|> pure (Left "An integer age is needed"))

decodePE :: BSL.ByteString -> Maybe (Person Covered (Either Text))
decodePE = decode

That does exhibit the behaviour I want

λ> let e0 = decodePE bs0
λ> e0
Just (Person {name = Right "the name", age = Right 17})
λ> let e1 = decodePE bs1
λ> e1
Just (Person {name = Right "the name", age = Left "An integer age is needed"})

In closing

I think everyone will agree that the FromJSON instances are increasingly messy. I think that can be fixed by putting some thought into what a more pleasing API should look like.

I'd also like to mix in validation beyond what aeson offers out-of-the-box, which really only is "is the field present?" and "does the value have the correct type?". For instance, Once we know there is a field called age, and that it's an Int, then we might want to make sure it's non-negitive, or that the person is at least 18. I'm guessing that wouldn't be too difficult.

Finally, I'd love to see examples of using HKDs for parsing/validation in the wild. It's probably easiest to reach me at @magthe@mastodon.technology.

Tags: haskell hkd json
19 Mar 2021

Custom monad with servant and throwing errors

In the past I've always used scotty when writing web services. This was mostly due to laziness, I found working out how to use scotty a lot easier than servant, so basically I was being lazy. Fairly quickly I bumped into some limitations in scotty, but at first the workarounds didn't add too much complexity and were acceptable. A few weeks ago they started weighing on me though and I decided to look into servant and since I really liked what I found I've started moving all projects to use servant.

In several of the projects I've used tagless final style and defined a type based on ReaderT holding configuration over IO, that is something like

newtype AppM a = AppM {unAppM : ReaderT Config IO a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader Config
    )

runAppM :: AppM a -> Config -> IO a
runAppM app = runReaderT (unAppM app)

I found that servant is very well suited to this style through hoistServer and there are several examples on how to use it with a ReaderT-based type like above. The first one I found is in the servant cookbook. However, as I realised a bit later, using a simple type like this doesn't make it easy to trigger responses with status other than 200 OK. When I looked at the definition of the type for writing handlers that ships with servant, Handler, I decided to try to use the following type in my service

newtype AppM a = AppM {unAppM : ReaderT Config (ExceptT ServerError IO) a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader Config
    )

runAppM :: AppM a -> Config -> IO (Either ServerError a)
runAppM app = runExceptT . runReaderT (unAppM app)

The natural transformation required by hoistServer can then be written like

nt :: AppM a -> Handler a
nt x =
  liftIO (runAppM x cfg) >>= \case
    Right v -> pure v
    Left err -> throwError err

I particularly like how clearly this suggests a way to add custom errors if I want that.

  1. Swap out ServerError for my custom error type in AppM.
  2. Write a function to transform my custom error type into a ServerError, transformCustomError :: CustomError -> ServerError.
  3. use throwError $ transformCustomError err in the Left branch of nt.

A slight complication with MonadUnliftIO

I was using unliftio in my service, and as long as I based my monad stack only on ReaderT that worked fine. I even got the MonadUnliftIO instance for free through automatic deriving. ExceptT isn't a stateless monad though, so using unliftio is out of the question, instead I had to switch to MonadBaseControl and the packages that work with it. Defining and instance of MonadBaseControl looked a bit daunting, but luckily Handler has an instance of it that I used as inspiration.

First off MonadBaseControl requires the type to also be an instance of MonadBase. There's an explicit implementation for Handler, but I found that it can be derived automatically, so I took the lazy route.

The instance of MonadBaseControl for AppM ended up looking like this

instance MonadBaseControl IO AppM where
  type StM AppM a = Either ServerError a

  liftBaseWith f = AppM (liftBaseWith (\g -> f (g . unAppM)))
  restoreM = AppM . restoreM

I can't claim to really understand what's going on in that definition, but I have Alexis King's article on Demystifying MonadBaseControl on my list of things to read.

Tags: haskell servant
14 Mar 2021

Keeping todo items in org-roam

A while ago I made an attempt to improve my work habits by keeping a document with TODO items. It lasted only for a while, and I've since had the intention to make another attempt. Since then I've started using org-roam and I've managed to create a habit of writing daily journal notes using org-roam's daily-notes. A few times I've thought that it might fit me well to put TODO items in the notes, but that would mean that I'd have to somehow keep track of them. At first I manually added a tag to each journal fily containing a TODO item. That didn't work very well at all, which should have been obvious up front. Then I added the folders where I keep roam files and journals to org-agenda-files, that worked a lot better. I'd still be using that, even if I expected it to slow down considerably as the number of files grow, but then I found a post on dynamic and fast agenda with org-roam.

I adjusted it slightly to fit my own setup a bit better, i.e. I made a Spacemacs layer, roam-extra, I use the tag todo, and I use a different hook to get the tag added on opening an org-roam file.

The layer consists of a single file, layers/roam-extra/funcs.el. In it I define 4 functions (they are pretty much copies of the functions in the post linked above):

  1. roam-extra:todo-p - returns non-nil if the current current buffer contains a TODO item.
  2. roam-extra:update-todo-tag - updates the tags of the current buffer to reflect the presence of TODO items, i.e. ensure the the tag todo is present iff there's a TODO item.
  3. roam-extra:todo-files - uses the org-roam DB to return a list of all files containing the tag todo.
  4. roam-extra:update-todo-files - adjusts 'org-agenda-files to contain only the files with TODO items.

I've put the full contents of the file at the end of the post.

To ensure that the todo tag is correct in all org-mode files I've added roam-extra:update-todo-tag to hooks that are invoked on opening an org-ram file and when saving a file. (I would love to find a more specialise hook than before-save-hook, but it works for now.)

(add-hook 'org-roam-file-setup-hook #'roam-extra:update-todo-tag)
(add-hook 'before-save-hook #'roam-extra:update-todo-tag)

To ensure that the list of files with TODO items is kept up to date when I open I also wrap org-agenda in an advice so roam-extra:update-todo-files is called prior to the agenda being opened.

(advice-add 'org-agenda :before #'roam-extra:update-todo-files)

The layer, layers/roam-extra/funcs.el

(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))

(defun roam-extra:update-todo-tag ()
  "Update TODO tag in the current buffer."
  (when (and (not (active-minibuffer-window))
             (org-roam--org-file-p buffer-file-name))
    (let* ((file (buffer-file-name (buffer-base-buffer)))
           (all-tags (org-roam--extract-tags file))
           (prop-tags (org-roam--extract-tags-prop file))
           (tags prop-tags))
      (if (roam-extra:todo-p)
          (setq tags (seq-uniq (cons "todo" tags)))
        (setq tags (remove "todo" tags)))
      (unless (equal prop-tags tags)
        (org-roam--set-global-prop
         "roam_tags"
         (combine-and-quote-strings tags))))))

(defun roam-extra:todo-files ()
  "Return a list of note files containing todo tag."
  (seq-map
   #'car
   (org-roam-db-query
    [:select file
             :from tags
             :where (like tags (quote "%\"todo\"%"))])))

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