*sigh*

Main.hs

module Main (main) where

import           Control.Monad.RWS
import           Control.Monad.Writer
import           Data.Binary.Builder
import qualified Data.ByteString.Lazy as Lazy
import           Data.Hashable
import           Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as Map
-- import           Data.Map (Map)
-- import qualified Data.Map as Map
import           Data.Word

data Node = Node
  { val  :: Word8
  , next :: Node
  }

instance Eq Node where
  Node a _ == Node b _ = a == b
instance Ord Node where -- for use in Data.Map
  Node a _ < Node b _ = a < b
instance Hashable Node where -- for use in Data.HashMap.Lazy
  hash (Node a _) = fromIntegral a

type M = HashMap Node Word8
-- type M = Map Node Word8
type Encoder = RWST M M Word8 (Writer Builder) ()

runEncoder :: Encoder -> [Word8]
runEncoder rwst =
  let knot ~(_, _, m) = runRWST rwst m 0
      (_, b) = runWriter $ mfix knot
  in Lazy.unpack $ toLazyByteString b

encodeNode :: Node -> Encoder
encodeNode n = do
  pos <- get
  put $ pos + 1
  m <- ask
  tell $ Map.singleton n pos
  let valbuilder = singleton $ val n
      nextbuilder = singleton $ m Map.! (next n)
  lift . tell $ valbuilder <> nextbuilder

encodeCycle :: Encoder
encodeCycle =
  let n0 = Node 0 n1
      n1 = Node 1 n0
  in do
    encodeNode n0
    encodeNode n1

main :: IO ()
main = putStrLn . show . runEncoder $ encodeCycle

test.cabal

name:           test
version:        0.1
build-type:     Simple
cabal-version:  >= 1.2

executable test
  hs-source-dirs:  src
  build-depends:   base,
                   binary,
                   bytestring,
                   containers,
                   hashable,
                   unordered-containers,
                   mtl
  ghc-options:     -Wall
  main-is:         Main.hs

See related StackOverflow post. As it turns out, unsurprisingly, I'm an even bigger moron than I thought: my Ord instance is broken. It needs to define either >= or compare.

No! It's <= or compare :) Cheers!