hamt/HAMTVisualisation.ipynb

{
 "cells": [
  {
   "cell_type": "code",
   "execution_count": 1,
   "metadata": {},
   "outputs": [],
   "source": [
    "{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n",
    "{-# LANGUAGE TypeSynonymInstances #-}\n",
    "{-# LANGUAGE FlexibleInstances #-}\n",
    "\n",
    "import Data.Bits             (Bits (bit, complement, popCount, shiftR, (.&.), (.|.)),\n",
    "                              FiniteBits (finiteBitSize))\n",
    "import Data.ByteArray.Hash   (FnvHash32 (..), fnv1Hash)\n",
    "import Data.ByteString.Char8 (pack)\n",
    "import Data.Char             (intToDigit)\n",
    "import Data.Semigroup        ((<>))\n",
    "import Data.Vector           (Vector, drop, singleton, take, (!), (//))\n",
    "import Data.Word             (Word16, Word32)\n",
    "import Numeric               (showIntAtBase)\n",
    "import Prelude               hiding (drop, lookup, take)\n",
    "import System.TimeIt         (timeIt)\n",
    "import Text.Show.Pretty      (pPrint)"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 2,
   "metadata": {},
   "outputs": [],
   "source": [
    "newtype Binary a = Binary a deriving (Enum, Ord, Real, Integral, Eq, Num, Bits, FiniteBits)\n",
    "\n",
    "instance (FiniteBits a, Show a, Integral a) => Show (Binary a) where\n",
    "    show (Binary a) = let\n",
    "        str = showIntAtBase 2 intToDigit a \"\"\n",
    "        size = finiteBitSize a\n",
    "        in replicate (size - length str) '0' <> str"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 3,
   "metadata": {},
   "outputs": [],
   "source": [
    "type Hash = Binary Word32\n",
    "type Bitmap = Binary Word16\n",
    "type Shift = Int\n",
    "\n",
    "class Hashable a where\n",
    "    hash :: a -> Hash"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 4,
   "metadata": {},
   "outputs": [],
   "source": [
    "instance Hashable String where\n",
    "    hash s = let\n",
    "        FnvHash32 h = fnv1Hash (pack s)\n",
    "        in Binary h"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 5,
   "metadata": {},
   "outputs": [],
   "source": [
    "data HAMT key value\n",
    "    = None\n",
    "    | Leaf Hash key value\n",
    "    | Many Bitmap (Vector (HAMT key value))\n",
    "    | Full (Vector (HAMT key value))\n",
    "    | Coll Hash (Vector (key, value))\n",
    "    deriving (Show)\n",
    "\n",
    "empty :: HAMT key value\n",
    "empty = None"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 6,
   "metadata": {},
   "outputs": [
    {
     "data": {
      "text/html": [
       "<style>/* Styles used for the Hoogle display in the pager */\n",
       ".hoogle-doc {\n",
       "display: block;\n",
       "padding-bottom: 1.3em;\n",
       "padding-left: 0.4em;\n",
       "}\n",
       ".hoogle-code {\n",
       "display: block;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "}\n",
       ".hoogle-text {\n",
       "display: block;\n",
       "}\n",
       ".hoogle-name {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-head {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-sub {\n",
       "display: block;\n",
       "margin-left: 0.4em;\n",
       "}\n",
       ".hoogle-package {\n",
       "font-weight: bold;\n",
       "font-style: italic;\n",
       "}\n",
       ".hoogle-module {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-class {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       ".get-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "white-space: pre-wrap;\n",
       "}\n",
       ".show-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "margin-left: 1em;\n",
       "}\n",
       ".mono {\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "}\n",
       ".err-msg {\n",
       "color: red;\n",
       "font-style: italic;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "display: block;\n",
       "}\n",
       "#unshowable {\n",
       "color: red;\n",
       "font-weight: bold;\n",
       "}\n",
       ".err-msg.in.collapse {\n",
       "padding-top: 0.7em;\n",
       "}\n",
       "\n",
       ".highlight-code {\n",
       "white-space: pre;\n",
       "font-family: monospace;\n",
       "}\n",
       "\n",
       ".suggestion-warning { \n",
       "font-weight: bold;\n",
       "color: rgb(200, 130, 0);\n",
       "}\n",
       ".suggestion-error { \n",
       "font-weight: bold;\n",
       "color: red;\n",
       "}\n",
       ".suggestion-name {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       "</style><div class=\"suggestion-name\" style=\"clear:both;\">Redundant bracket</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">(bit bitsPerSubkey) - 1</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">bit bitsPerSubkey - 1</div></div><div class=\"suggestion-name\" style=\"clear:both;\">Redundant bracket</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">(bit (2 ^ bitsPerSubkey)) - 1</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">bit (2 ^ bitsPerSubkey) - 1</div></div><div class=\"suggestion-name\" style=\"clear:both;\">Move brackets to avoid $</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">(fromIntegral $ shiftR hash shift) .&. subkeyMask</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">fromIntegral (shiftR hash shift) .&. subkeyMask</div></div>"
      ],
      "text/plain": [
       "Line 5: Redundant bracket\n",
       "Found:\n",
       "(bit bitsPerSubkey) - 1\n",
       "Why not:\n",
       "bit bitsPerSubkey - 1Line 8: Redundant bracket\n",
       "Found:\n",
       "(bit (2 ^ bitsPerSubkey)) - 1\n",
       "Why not:\n",
       "bit (2 ^ bitsPerSubkey) - 1Line 11: Move brackets to avoid $\n",
       "Found:\n",
       "(fromIntegral $ shiftR hash shift) .&. subkeyMask\n",
       "Why not:\n",
       "fromIntegral (shiftR hash shift) .&. subkeyMask"
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    }
   ],
   "source": [
    "bitsPerSubkey :: Int\n",
    "bitsPerSubkey = 4\n",
    "\n",
    "subkeyMask :: Bitmap\n",
    "subkeyMask = (bit bitsPerSubkey) - 1\n",
    "\n",
    "fullMask :: Bitmap\n",
    "fullMask = (bit (2^bitsPerSubkey)) - 1\n",
    "\n",
    "subkey :: Hash -> Shift -> Int\n",
    "subkey hash shift = fromIntegral $ (fromIntegral $ shiftR hash shift) .&. subkeyMask\n",
    "\n",
    "maskIndex :: Bitmap -> Bitmap -> Int\n",
    "maskIndex bitmap mask = popCount (bitmap .&. (mask - 1))\n",
    "\n",
    "bitMask :: Hash -> Shift -> Bitmap\n",
    "bitMask hash shift = bit (subkey hash shift)"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 7,
   "metadata": {},
   "outputs": [],
   "source": [
    "insertAt :: Vector a -> Int -> a -> Vector a\n",
    "insertAt vector index a = take index vector <> singleton a <> drop index vector\n",
    "\n",
    "updateAt :: Vector a -> Int -> a -> Vector a\n",
    "updateAt vector index a = vector // [(index, a)]\n",
    "\n",
    "deleteAt :: Vector a -> Int -> Vector a\n",
    "deleteAt vector index = take index vector <> drop (index+1) vector"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 8,
   "metadata": {},
   "outputs": [
    {
     "data": {
      "text/html": [
       "<style>/* Styles used for the Hoogle display in the pager */\n",
       ".hoogle-doc {\n",
       "display: block;\n",
       "padding-bottom: 1.3em;\n",
       "padding-left: 0.4em;\n",
       "}\n",
       ".hoogle-code {\n",
       "display: block;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "}\n",
       ".hoogle-text {\n",
       "display: block;\n",
       "}\n",
       ".hoogle-name {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-head {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-sub {\n",
       "display: block;\n",
       "margin-left: 0.4em;\n",
       "}\n",
       ".hoogle-package {\n",
       "font-weight: bold;\n",
       "font-style: italic;\n",
       "}\n",
       ".hoogle-module {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-class {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       ".get-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "white-space: pre-wrap;\n",
       "}\n",
       ".show-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "margin-left: 1em;\n",
       "}\n",
       ".mono {\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "}\n",
       ".err-msg {\n",
       "color: red;\n",
       "font-style: italic;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "display: block;\n",
       "}\n",
       "#unshowable {\n",
       "color: red;\n",
       "font-weight: bold;\n",
       "}\n",
       ".err-msg.in.collapse {\n",
       "padding-top: 0.7em;\n",
       "}\n",
       "\n",
       ".highlight-code {\n",
       "white-space: pre;\n",
       "font-family: monospace;\n",
       "}\n",
       "\n",
       ".suggestion-warning { \n",
       "font-weight: bold;\n",
       "color: rgb(200, 130, 0);\n",
       "}\n",
       ".suggestion-error { \n",
       "font-weight: bold;\n",
       "color: red;\n",
       "}\n",
       ".suggestion-name {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       "</style><div class=\"suggestion-name\" style=\"clear:both;\">Eta reduce</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">insert key value hamt = insert' 0 (hash key) key value hamt</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">insert key = insert' 0 (hash key) key</div></div>"
      ],
      "text/plain": [
       "Line 2: Eta reduce\n",
       "Found:\n",
       "insert key value hamt = insert' 0 (hash key) key value hamt\n",
       "Why not:\n",
       "insert key = insert' 0 (hash key) key"
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    }
   ],
   "source": [
    "insert :: (Hashable key, Eq key) => key -> value -> HAMT key value -> HAMT key value\n",
    "insert key value hamt = insert' 0 (hash key) key value hamt\n",
    "\n",
    "insert' :: Eq key => Shift -> Hash -> key -> value -> HAMT key value -> HAMT key value\n",
    "insert' shift hash key value None = Leaf hash key value\n",
    "\n",
    "insert' shift hash key value leaf@(Leaf leafHash leafKey leafValue)\n",
    "    | hash == leafHash =\n",
    "        if key == leafKey\n",
    "        then Leaf hash key value\n",
    "        else Coll hash (insertAt (singleton (leafKey, leafValue)) 0 (key, value))\n",
    "    | otherwise = insert' shift hash key value (Many (bitMask leafHash shift) (singleton leaf))\n",
    "\n",
    "insert' shift hash key value (Many bitmap vector)\n",
    "    | bitmap .&. mask == 0 = let\n",
    "        leaf = Leaf hash key value\n",
    "        vector' = insertAt vector index leaf\n",
    "        bitmap' = bitmap .|. mask\n",
    "        in if bitmap' == fullMask\n",
    "          then Full vector'\n",
    "          else Many bitmap' vector'\n",
    "    | otherwise = let\n",
    "        subtree = vector ! index\n",
    "        subtree' = insert' (shift+bitsPerSubkey) hash key value subtree\n",
    "        vector' = updateAt vector index subtree'\n",
    "        in Many bitmap vector'\n",
    "    where\n",
    "        mask = bitMask hash shift\n",
    "        index = maskIndex bitmap mask\n",
    "\n",
    "insert' shift hash key value (Full vector) =\n",
    "    let\n",
    "        subtree = vector ! index\n",
    "        subtree' = insert' (shift+bitsPerSubkey) hash key value subtree\n",
    "        vector' = updateAt vector index subtree'\n",
    "    in Full vector'\n",
    "    where\n",
    "        index = subkey hash shift\n",
    "\n",
    "insert' shift hash key value coll@(Coll collHash vector)\n",
    "    | hash == collHash = Coll collHash (updateOrPrepend 0 (length vector) key value vector)\n",
    "    | otherwise = insert' shift hash key value (Many (bitMask collHash shift) (singleton coll))\n",
    "    where\n",
    "        updateOrPrepend index len key value vector\n",
    "            | index == len = insertAt vector 0 (key, value)\n",
    "            | otherwise = let\n",
    "                (currKey, _) = vector ! index\n",
    "                in if currKey == key\n",
    "                    then updateAt vector index (key, value)\n",
    "                    else updateOrPrepend (index+1) len key value vector"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 9,
   "metadata": {},
   "outputs": [],
   "source": [
    "fromList :: (Hashable key, Eq key) => [(key, value)] -> HAMT key value\n",
    "fromList = foldr (uncurry insert) empty"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 10,
   "metadata": {},
   "outputs": [
    {
     "data": {
      "text/html": [
       "<style>/* Styles used for the Hoogle display in the pager */\n",
       ".hoogle-doc {\n",
       "display: block;\n",
       "padding-bottom: 1.3em;\n",
       "padding-left: 0.4em;\n",
       "}\n",
       ".hoogle-code {\n",
       "display: block;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "}\n",
       ".hoogle-text {\n",
       "display: block;\n",
       "}\n",
       ".hoogle-name {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-head {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-sub {\n",
       "display: block;\n",
       "margin-left: 0.4em;\n",
       "}\n",
       ".hoogle-package {\n",
       "font-weight: bold;\n",
       "font-style: italic;\n",
       "}\n",
       ".hoogle-module {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-class {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       ".get-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "white-space: pre-wrap;\n",
       "}\n",
       ".show-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "margin-left: 1em;\n",
       "}\n",
       ".mono {\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "}\n",
       ".err-msg {\n",
       "color: red;\n",
       "font-style: italic;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "display: block;\n",
       "}\n",
       "#unshowable {\n",
       "color: red;\n",
       "font-weight: bold;\n",
       "}\n",
       ".err-msg.in.collapse {\n",
       "padding-top: 0.7em;\n",
       "}\n",
       "\n",
       ".highlight-code {\n",
       "white-space: pre;\n",
       "font-family: monospace;\n",
       "}\n",
       "\n",
       ".suggestion-warning { \n",
       "font-weight: bold;\n",
       "color: rgb(200, 130, 0);\n",
       "}\n",
       ".suggestion-error { \n",
       "font-weight: bold;\n",
       "color: red;\n",
       "}\n",
       ".suggestion-name {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       "</style><div class=\"suggestion-name\" style=\"clear:both;\">Eta reduce</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">lookup key hamt = lookup' 0 (hash key) key hamt</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">lookup key = lookup' 0 (hash key) key</div></div>"
      ],
      "text/plain": [
       "Line 2: Eta reduce\n",
       "Found:\n",
       "lookup key hamt = lookup' 0 (hash key) key hamt\n",
       "Why not:\n",
       "lookup key = lookup' 0 (hash key) key"
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    }
   ],
   "source": [
    "lookup :: (Hashable key, Eq key) => key -> HAMT key value -> Maybe value\n",
    "lookup key hamt = lookup' 0 (hash key) key hamt\n",
    "\n",
    "lookup' :: Eq key => Shift -> Hash -> key -> HAMT key value -> Maybe value\n",
    "lookup' shift hash key None = Nothing\n",
    "\n",
    "lookup' shift hash key (Leaf leafHash leafKey leafValue)\n",
    "    | hash == leafHash && key == leafKey = Just leafValue\n",
    "    | otherwise = Nothing\n",
    "\n",
    "lookup' shift hash key (Many bitmap vector)\n",
    "    | bitmap .&. mask == 0 = Nothing\n",
    "    | otherwise = lookup' (shift+bitsPerSubkey) hash key (vector ! index)\n",
    "    where\n",
    "        mask = bitMask hash shift\n",
    "        index = maskIndex bitmap mask\n",
    "\n",
    "lookup' shift hash key (Full vector) = lookup' (shift+bitsPerSubkey) hash key (vector ! index)\n",
    "    where\n",
    "        index = subkey hash shift\n",
    "\n",
    "lookup' shift hash key (Coll collHash vector)\n",
    "    | hash == collHash = findMatching 0 (length vector) key vector\n",
    "    | otherwise = Nothing\n",
    "    where\n",
    "        findMatching index len key vector\n",
    "            | index == len = Nothing\n",
    "            | otherwise = let\n",
    "                (currKey, currValue) = vector ! index\n",
    "                in if currKey == key\n",
    "                    then Just currValue\n",
    "                    else findMatching (index+1) len key vector"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 11,
   "metadata": {},
   "outputs": [],
   "source": [
    "instance Hashable Int where\n",
    "    hash int = Binary (fromIntegral int)"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 12,
   "metadata": {},
   "outputs": [
    {
     "data": {
      "text/html": [
       "<style>/* Styles used for the Hoogle display in the pager */\n",
       ".hoogle-doc {\n",
       "display: block;\n",
       "padding-bottom: 1.3em;\n",
       "padding-left: 0.4em;\n",
       "}\n",
       ".hoogle-code {\n",
       "display: block;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "}\n",
       ".hoogle-text {\n",
       "display: block;\n",
       "}\n",
       ".hoogle-name {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-head {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-sub {\n",
       "display: block;\n",
       "margin-left: 0.4em;\n",
       "}\n",
       ".hoogle-package {\n",
       "font-weight: bold;\n",
       "font-style: italic;\n",
       "}\n",
       ".hoogle-module {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-class {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       ".get-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "white-space: pre-wrap;\n",
       "}\n",
       ".show-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "margin-left: 1em;\n",
       "}\n",
       ".mono {\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "}\n",
       ".err-msg {\n",
       "color: red;\n",
       "font-style: italic;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "display: block;\n",
       "}\n",
       "#unshowable {\n",
       "color: red;\n",
       "font-weight: bold;\n",
       "}\n",
       ".err-msg.in.collapse {\n",
       "padding-top: 0.7em;\n",
       "}\n",
       "\n",
       ".highlight-code {\n",
       "white-space: pre;\n",
       "font-family: monospace;\n",
       "}\n",
       "\n",
       ".suggestion-warning { \n",
       "font-weight: bold;\n",
       "color: rgb(200, 130, 0);\n",
       "}\n",
       ".suggestion-error { \n",
       "font-weight: bold;\n",
       "color: red;\n",
       "}\n",
       ".suggestion-name {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       "</style><div class=\"suggestion-name\" style=\"clear:both;\">Eta reduce</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">delete key hamt = delete' 0 (hash key) key hamt</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">delete key = delete' 0 (hash key) key</div></div><div class=\"suggestion-name\" style=\"clear:both;\">Use uncurry</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">\\ (leafKey, leafValue) -> Leaf collHash leafKey leafValue</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">uncurry (Leaf collHash)</div></div>"
      ],
      "text/plain": [
       "Line 2: Eta reduce\n",
       "Found:\n",
       "delete key hamt = delete' 0 (hash key) key hamt\n",
       "Why not:\n",
       "delete key = delete' 0 (hash key) keyLine 43: Use uncurry\n",
       "Found:\n",
       "\\ (leafKey, leafValue) -> Leaf collHash leafKey leafValue\n",
       "Why not:\n",
       "uncurry (Leaf collHash)"
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    }
   ],
   "source": [
    "delete :: (Hashable key, Eq key) => key -> HAMT key value -> HAMT key value\n",
    "delete key hamt = delete' 0 (hash key) key hamt\n",
    "\n",
    "delete' :: Eq key => Shift -> Hash -> key -> HAMT key value -> HAMT key value\n",
    "delete' shift hash key None = None\n",
    "\n",
    "delete' shift hash key leaf@(Leaf leafHash leafKey leafValue)\n",
    "    | hash == leafHash && key == leafKey = None\n",
    "    | otherwise = leaf\n",
    "\n",
    "delete' shift hash key many@(Many bitmap vector)\n",
    "    | bitmap .&. mask == 0 = many\n",
    "    | otherwise = let\n",
    "        subtree = vector ! index\n",
    "        subtree' = delete' (shift+bitsPerSubkey) hash key subtree\n",
    "        in case subtree' of\n",
    "            None -> if length vector == 1\n",
    "                then None\n",
    "                else Many (bitmap .&. complement mask) (deleteAt vector index)\n",
    "            Leaf{} -> if length vector == 1\n",
    "                then subtree'\n",
    "                else Many bitmap (updateAt vector index subtree')\n",
    "            _ -> Many bitmap (updateAt vector index subtree')\n",
    "    where\n",
    "        mask = bitMask hash shift\n",
    "        index = maskIndex bitmap mask\n",
    "\n",
    "delete' shift hash key (Full vector) =\n",
    "    let\n",
    "        subtree = vector ! index\n",
    "        subtree' = delete' (shift+bitsPerSubkey) hash key subtree\n",
    "    in case subtree' of\n",
    "        None -> Many (fullMask .&. complement mask) (deleteAt vector index)\n",
    "        _ -> Full (updateAt vector index subtree')\n",
    "    where\n",
    "        mask = bitMask hash shift\n",
    "        index = subkey hash shift\n",
    "\n",
    "delete' shift hash key coll@(Coll collHash vector)\n",
    "    | hash == collHash = let\n",
    "        vector' = deleteMatching 0 (length vector) key vector\n",
    "        in if length vector' == 1\n",
    "            then (\\(leafKey, leafValue) -> Leaf collHash leafKey leafValue) $ vector' ! 0\n",
    "            else Coll collHash vector'\n",
    "    | otherwise = coll\n",
    "    where\n",
    "        deleteMatching index len key vector\n",
    "            | index == len = vector\n",
    "            | otherwise = let\n",
    "                (currKey, _) = vector ! index\n",
    "                in if currKey == key\n",
    "                    then deleteAt vector index\n",
    "                    else deleteMatching (index+1) len key vector"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 13,
   "metadata": {},
   "outputs": [],
   "source": [
    "import IHaskell.Display.Graphviz\n",
    "import Control.Monad.Trans.State.Strict\n",
    "import Control.Monad.Trans.Writer.CPS\n",
    "import Control.Monad.Trans.Class\n",
    "import qualified Data.Vector as Vector\n",
    "import Data.List (intercalate, intersperse, foldl')\n",
    "import qualified Prelude"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 14,
   "metadata": {},
   "outputs": [],
   "source": [
    "data TreeNode\n",
    "    = TreeNode { nodeId :: Int, bitmap   :: String, fields :: [Int] }\n",
    "    | LeafNode { leafId :: Int, leafHash :: String, leafKey :: String, leafValue :: String }\n",
    "    | CollNode { collId :: Int, collHash :: String, collPairs :: [(String, String)]}\n",
    "    deriving (Eq, Show)"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 15,
   "metadata": {},
   "outputs": [
    {
     "data": {
      "text/html": [
       "<style>/* Styles used for the Hoogle display in the pager */\n",
       ".hoogle-doc {\n",
       "display: block;\n",
       "padding-bottom: 1.3em;\n",
       "padding-left: 0.4em;\n",
       "}\n",
       ".hoogle-code {\n",
       "display: block;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "}\n",
       ".hoogle-text {\n",
       "display: block;\n",
       "}\n",
       ".hoogle-name {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-head {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-sub {\n",
       "display: block;\n",
       "margin-left: 0.4em;\n",
       "}\n",
       ".hoogle-package {\n",
       "font-weight: bold;\n",
       "font-style: italic;\n",
       "}\n",
       ".hoogle-module {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-class {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       ".get-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "white-space: pre-wrap;\n",
       "}\n",
       ".show-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "margin-left: 1em;\n",
       "}\n",
       ".mono {\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "}\n",
       ".err-msg {\n",
       "color: red;\n",
       "font-style: italic;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "display: block;\n",
       "}\n",
       "#unshowable {\n",
       "color: red;\n",
       "font-weight: bold;\n",
       "}\n",
       ".err-msg.in.collapse {\n",
       "padding-top: 0.7em;\n",
       "}\n",
       "\n",
       ".highlight-code {\n",
       "white-space: pre;\n",
       "font-family: monospace;\n",
       "}\n",
       "\n",
       ".suggestion-warning { \n",
       "font-weight: bold;\n",
       "color: rgb(200, 130, 0);\n",
       "}\n",
       ".suggestion-error { \n",
       "font-weight: bold;\n",
       "color: red;\n",
       "}\n",
       ".suggestion-name {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       "</style><div class=\"suggestion-name\" style=\"clear:both;\">Use bimap</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">\\ (k, v) -> (show k, show v)</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">Data.Bifunctor.bimap show show</div></div><div class=\"suggestion-name\" style=\"clear:both;\">Avoid lambda using `infix`</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">(\\ l -> l ++ \";\\n\")</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">(++ \";\\n\")</div></div>"
      ],
      "text/plain": [
       "Line 27: Use bimap\n",
       "Found:\n",
       "\\ (k, v) -> (show k, show v)\n",
       "Why not:\n",
       "Data.Bifunctor.bimap show showLine 64: Avoid lambda using `infix`\n",
       "Found:\n",
       "(\\ l -> l ++ \";\\n\")\n",
       "Why not:\n",
       "(++ \";\\n\")"
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    }
   ],
   "source": [
    "getFreshId :: State Int Int\n",
    "getFreshId = do\n",
    "    currentId <- get\n",
    "    put (currentId+1)\n",
    "    pure currentId\n",
    "\n",
    "number :: (Show k, Show v) => HAMT k v -> WriterT [TreeNode] (State Int) Int\n",
    "number None = do\n",
    "    tell mempty\n",
    "    pure 0\n",
    "number (Leaf h k v) = do\n",
    "    i <- lift getFreshId\n",
    "    tell [LeafNode i (show h) (show k) (show v)]\n",
    "    pure i\n",
    "number (Many b hs) = do\n",
    "    i <- lift getFreshId\n",
    "    numbered <- Vector.toList <$> traverse number hs\n",
    "    tell [TreeNode i (show b) numbered]\n",
    "    pure i\n",
    "number (Full hs) = do\n",
    "    i <- lift getFreshId\n",
    "    numbered <- Vector.toList <$> traverse number hs\n",
    "    tell [TreeNode i \"FULL\" numbered]\n",
    "    pure i\n",
    "number (Coll h kvs) = do\n",
    "    i <- lift getFreshId\n",
    "    tell [CollNode i (show h) (map (\\(k,v) -> (show k, show v)) (Vector.toList kvs))]\n",
    "    pure i\n",
    "\n",
    "nodeData :: (Show k, Show v) => HAMT k v -> [TreeNode]\n",
    "nodeData = flip evalState 0 . execWriterT . number\n",
    "\n",
    "escape = concatMap escaper\n",
    "    where\n",
    "        escaper :: Char -> String\n",
    "        escaper c = case c of\n",
    "            '\"'  -> \"\\\\\\\"\"\n",
    "            '\\\\' -> \"\\\\\\\\\"\n",
    "            _    -> [c]\n",
    "\n",
    "nodeLines :: TreeNode -> [String]\n",
    "nodeLines (LeafNode i h k v) = let\n",
    "    label = intercalate \"|\" [h, k, v]\n",
    "    line = (\"n\" ++ show i) ++ \" \" ++ \"[label=\\\"\" ++ escape label ++ \"\\\"]\"\n",
    "    in [line]\n",
    "nodeLines (CollNode i h kvs) = let\n",
    "    label = intercalate \"|\" [h, shownKvs]\n",
    "    line = (\"n\" ++ show i) ++ \" \" ++ \"[label=\\\"\" ++ escape label ++ \"\\\"]\"\n",
    "    in [line]\n",
    "    where\n",
    "        shownKvs = intercalate \"|\" $ map (\\(k,v) -> k ++ \" : \" ++ v) kvs\n",
    "nodeLines (TreeNode i b fs) = let\n",
    "    indices = Prelude.take (length fs) [0..]\n",
    "    pairs = zip indices fs\n",
    "    edges = flip map pairs $ \\(f,t) -> \"n\" ++ show i ++ \":\" ++ \"f\" ++ show f ++ \" -> \" ++ \"n\" ++ show t\n",
    "    fields = flip map indices $ \\ix -> \"<f\" ++ show ix ++ \">\"\n",
    "    label = intercalate \"|\" $ b:fields\n",
    "    line = (\"n\" ++ show i) ++ \" \" ++ \"[label=\\\"\" ++ escape label ++ \"\\\"]\"\n",
    "    in (line:edges)\n",
    "\n",
    "makeLines = concatMap nodeLines\n",
    "\n",
    "makeDotLines :: [String] -> String\n",
    "makeDotLines = concatMap (\\l -> l ++ \";\\n\")\n",
    "\n",
    "preamble = unlines\n",
    "    [ \"digraph {\"\n",
    "    , \"node [shape=record];\"\n",
    "    , \"splines=false;\"\n",
    "    , \"ranksep=2;\"\n",
    "    , \"nodesep=1;\"\n",
    "    ]\n",
    "postamble = unlines [\"}\"]\n",
    "\n",
    "makeDot :: String -> String\n",
    "makeDot str = preamble ++ str ++ postamble\n",
    "\n",
    "dotFromHAMT :: (Show k, Show v) => HAMT k v -> String\n",
    "dotFromHAMT = makeDot . makeDotLines. makeLines . nodeData"
   ]
  },
  {
   "cell_type": "code",
   "execution_count": 17,
   "metadata": {},
   "outputs": [
    {
     "data": {
      "text/html": [
       "<style>/* Styles used for the Hoogle display in the pager */\n",
       ".hoogle-doc {\n",
       "display: block;\n",
       "padding-bottom: 1.3em;\n",
       "padding-left: 0.4em;\n",
       "}\n",
       ".hoogle-code {\n",
       "display: block;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "}\n",
       ".hoogle-text {\n",
       "display: block;\n",
       "}\n",
       ".hoogle-name {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-head {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-sub {\n",
       "display: block;\n",
       "margin-left: 0.4em;\n",
       "}\n",
       ".hoogle-package {\n",
       "font-weight: bold;\n",
       "font-style: italic;\n",
       "}\n",
       ".hoogle-module {\n",
       "font-weight: bold;\n",
       "}\n",
       ".hoogle-class {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       ".get-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "white-space: pre-wrap;\n",
       "}\n",
       ".show-type {\n",
       "color: green;\n",
       "font-weight: bold;\n",
       "font-family: monospace;\n",
       "margin-left: 1em;\n",
       "}\n",
       ".mono {\n",
       "font-family: monospace;\n",
       "display: block;\n",
       "}\n",
       ".err-msg {\n",
       "color: red;\n",
       "font-style: italic;\n",
       "font-family: monospace;\n",
       "white-space: pre;\n",
       "display: block;\n",
       "}\n",
       "#unshowable {\n",
       "color: red;\n",
       "font-weight: bold;\n",
       "}\n",
       ".err-msg.in.collapse {\n",
       "padding-top: 0.7em;\n",
       "}\n",
       "\n",
       ".highlight-code {\n",
       "white-space: pre;\n",
       "font-family: monospace;\n",
       "}\n",
       "\n",
       ".suggestion-warning { \n",
       "font-weight: bold;\n",
       "color: rgb(200, 130, 0);\n",
       "}\n",
       ".suggestion-error { \n",
       "font-weight: bold;\n",
       "color: red;\n",
       "}\n",
       ".suggestion-name {\n",
       "font-weight: bold;\n",
       "}\n",
       "\n",
       "</style><div class=\"suggestion-name\" style=\"clear:both;\">Use tuple-section</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">flip (,) ()</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">(, ())</div></div>"
      ],
      "text/plain": [
       "Line 1: Use tuple-section\n",
       "Found:\n",
       "flip (,) ()\n",
       "Why not:\n",
       "(, ())"
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    },
    {
     "data": {
      "text/plain": [
       "\"digraph {\\nnode [shape=record];\\nsplines=false;\\nranksep=2;\\nnodesep=1;\\nn1 [label=\\\"00000000000000000000000000000000|0 : ()|4294967296 : ()\\\"];\\nn2 [label=\\\"00000000000000000000000000000001|1 : ()|4294967297 : ()\\\"];\\nn0 [label=\\\"0000000000000011|<f0>|<f1>\\\"];\\nn0:f0 -> n1;\\nn0:f1 -> n2;\\n}\\n\""
      ]
     },
     "metadata": {},
     "output_type": "display_data"
    }
   ],
   "source": [
    "dotFromHAMT (fromList (map (flip (,) ()) [0, 1, 2^32, 1 + (2^32)]) :: HAMT Int ())"
   ]
  }
 ],
 "metadata": {
  "kernelspec": {
   "display_name": "Haskell",
   "language": "haskell",
   "name": "haskell"
  },
  "language_info": {
   "codemirror_mode": "ihaskell",
   "file_extension": ".hs",
   "mimetype": "text/x-haskell",
   "name": "haskell",
   "pygments_lexer": "Haskell",
   "version": "9.2.8"
  }
 },
 "nbformat": 4,
 "nbformat_minor": 2
}