Transaction.hs

module Main.Transaction where

import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import Focus (Focus (..))
import qualified Focus
import StmHamt.Hamt (Hamt)
import qualified StmHamt.Hamt as StmHamt
import Prelude

data Transaction = forall result.
  (Show result, Eq result) =>
  Transaction
  { name :: Text,
    applyToHashMap :: HashMap Text Int -> (result, HashMap Text Int),
    applyToStmHamt :: Hamt (Text, Int) -> STM result
  }

instance Show Transaction where
  show = Text.unpack . name

lookup :: Text -> Transaction
lookup key =
  let name = fromString ("lookup " <> show key)
      applyToHashMap hashMap = (HashMap.lookup key hashMap, hashMap)
      applyToStmHamt hamt = (fmap . fmap) snd (StmHamt.lookup fst key hamt)
   in Transaction name applyToHashMap applyToStmHamt

insert :: Text -> Int -> Transaction
insert key value =
  let name = fromString ("insert " <> show key <> " " <> show value)
      applyToHashMap = ((),) . HashMap.insert key value
      applyToStmHamt hamt = StmHamt.insert fst (key, value) hamt $> ()
   in Transaction name applyToHashMap applyToStmHamt

-- | A transaction which can be used to manipulate hash collision
insertWithHash :: Int -> Text -> Int -> Transaction
insertWithHash hash key value =
  let name = fromString ("insert " <> show key <> " " <> show value)
      applyToHashMap = ((),) . HashMap.insert key value
      applyToStmHamt hamt = StmHamt.insertExplicitly hash ((==) key . fst) (key, value) hamt $> ()
   in Transaction name applyToHashMap applyToStmHamt

focus :: (forall m. (Monad m) => Focus Int m ()) -> Text -> Transaction
focus focus@(Focus conceal reveal) key =
  let name = "focus"
      applyToHashMap hashMap =
        let Identity (result, change) = case HashMap.lookup key hashMap of
              Just existingValue -> reveal existingValue
              Nothing -> conceal
            newHashMap = case change of
              Focus.Leave -> hashMap
              Focus.Set newValue -> HashMap.insert key newValue hashMap
              Focus.Remove -> HashMap.delete key hashMap
         in (result, newHashMap)
      applyToStmHamt =
        let stmHamtFocus = Focus.mappingInput (key,) snd focus
         in StmHamt.focus stmHamtFocus fst key
   in Transaction name applyToHashMap applyToStmHamt

insertUsingFocus :: Text -> Int -> Transaction
insertUsingFocus key value =
  let name = fromString ("insertUsingFocus " <> show key <> " " <> show value)
   in (focus (Focus.insert value) key) {name = name}

deleteUsingFocus :: Text -> Transaction
deleteUsingFocus key =
  let name = fromString ("deleteUsingFocus " <> show key)
   in (focus Focus.delete key) {name = name}

incrementUsingAdjustFocus :: Text -> Transaction
incrementUsingAdjustFocus key =
  let name = fromString ("incrementUsingAdjustFocus " <> show key)
   in (focus (Focus.adjust succ) key) {name = name}