A module taking the fuss of ids management away from Acid-State's IxSet

gistfile1.md

The extension module to IxSet library

{-# LANGUAGE DeriveDataTypeable, RecordWildCards, UndecidableInstances, GeneralizedNewtypeDeriving #-}
module Data.IxSet.Identified where

-- Block the standard prelude
import Prelude ()
-- Import a much more useful prelude from `classy-prelude` package
import ClassyPrelude
import Data.SafeCopy
import Data.IxSet as IxSet
import Control.Monad.State
import Data.Data

newtype Id a = Id {idValue :: Integer}
  deriving (Eq, Ord, Enum, Show, Data, Typeable, SafeCopy)

data Identified a = Identified {identifiedId :: Id a, identifiedValue :: a}
  deriving (Eq, Ord, Show, Data, Typeable)

instance (SafeCopy a) => SafeCopy (Identified a) where
  putCopy (Identified id value) = contain $ do
    safePut $ idValue id
    safePut value
  getCopy = contain $ Identified <$> (Id <$> safeGet) <*> safeGet

data IdentifiedIxSet a = 
  IdentifiedIxSet {
    identifiedIxSetNextId :: Id a,
    identifiedIxSetValue :: IxSet (Identified a)
  }
  deriving (Eq, Ord, Show, Data, Typeable)

instance (Indexable (Identified a), SafeCopy a, Typeable a, Ord a) => SafeCopy (IdentifiedIxSet a) where
  putCopy IdentifiedIxSet{..} = contain $ do
    safePut $ idValue identifiedIxSetNextId
    safePut $ IxSet.toList identifiedIxSetValue
  getCopy = 
    contain $ IdentifiedIxSet 
      <$> (Id <$> safeGet)
      <*> (IxSet.fromList <$> safeGet)

emptyIIS :: (Indexable (Identified a)) => IdentifiedIxSet a
emptyIIS = IdentifiedIxSet (Id 1) IxSet.empty

insertIIS :: (Ord a, Typeable a, Indexable (Identified a)) =>
  a -> IdentifiedIxSet a -> (Identified a, IdentifiedIxSet a)
insertIIS v = runState $ do
  IdentifiedIxSet{..} <- get
  let identified = Identified identifiedIxSetNextId v
  put $ IdentifiedIxSet
    (succ identifiedIxSetNextId)
    (IxSet.insert identified identifiedIxSetValue)
  return identified

updateIIS :: (Ord a, Typeable a, Indexable (Identified a), Typeable k) =>
  k -> a -> IdentifiedIxSet a -> (Identified a, IdentifiedIxSet a)
updateIIS k v = runState $ do
  iis@IdentifiedIxSet{..} <- get
  case getOne $ identifiedIxSetValue @= k of
    Just existing@(Identified id _) -> do
      let new = Identified id v
      put $ IdentifiedIxSet identifiedIxSetNextId 
        $ IxSet.insert new
        $ IxSet.delete existing
        $ identifiedIxSetValue
      return new
    Nothing -> do
      let identified = Identified identifiedIxSetNextId v
      put $ IdentifiedIxSet
        (succ identifiedIxSetNextId)
        (IxSet.insert identified identifiedIxSetValue)
      return identified

Usage in model declaration

data Record = Record {
  recordArtists :: [Id Artist],
  recordTitle :: Text
}

-- Note the absense of `id` field
data Artist = Artist {
  artistName :: Text
}

-- Note the absense of `nextId` fields and the `IdentifiedIxSet` type
data DB = DB {
  dbArtists :: IdentifiedIxSet Artist,
  dbRecords :: IdentifiedIxSet Record
}

instance Indexable (Identified Record) where
  empty = 
    ixSet [
      ixFun $ singleton . identifiedId,
      ixFun $ recordArtists . identifiedValue
    ]

instance Indexable (Identified Artist) where
  empty = 
    ixSet [
      ixFun $ singleton . identifiedId
    ]

As you can see IdentifiedIxSet takes away most of the fuss of dealing with ids in model declaration.

Usage in events

import Data.Label
import Data.Label.PureM

-- Generate lenses for our model records.
-- 
-- In this example we'll be using a generated `dbArtistsL` lens 
-- funciton particularly.
$(mkLabelsWith (++ "L") [''Artist, ''Record])

-- | An event which inserts the artist and returns it wrapped in the 
-- `Indentified` with the generated id. In the backround the `insertIIS`
-- function also increments the internal `nextId` value of the container
-- `IdentifiedIxSet`.
insertArtist :: Artist -> Update ContentDB (Identified Artist)
insertArtist artist = 
  modifyAndGet dbArtistsL $ insertIIS $ artist

modifyAndGet is a function proposed in this pull-request for fclabels library. If until now the pull request is still not merged, you can just copy-paste its source code to your project.