primula-board-0.0.1: BoardState.hs

{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,
  TypeSynonymInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}

-- | BoardState.hs
-- A module which contain happstack state instances.

module BoardState where

import Board

import Happstack.State
import Data.Typeable

import Control.Monad.State
import Control.Monad.Reader
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq

---

data BoardWrap = BoardWrap Board
                 deriving (Show, Typeable)

instance Version Post
$(deriveSerialize ''Post)

instance Version Thread
$(deriveSerialize ''Thread)

instance Version (Seq.Seq a) where mode = Primitive
instance Serialize a => Serialize (Seq.Seq a) where
    getCopy = contain $ fmap Seq.fromList safeGet
    putCopy = contain . safePut . F.toList

instance Version BoardWrap
$(deriveSerialize ''BoardWrap)

---

type Result = Either String Int

newPost' :: Bool -> Post -> Update BoardWrap Result
newPost' sage post = do
    BoardWrap board <- get
    putAndRet (newPost sage post board)

newThread' :: String -> Post -> Update BoardWrap Result
newThread' tag post = do
    BoardWrap board <- get
    putAndRet (newThread tag post board)

delPost' :: Int -> String -> Update BoardWrap Result
delPost' number password = do
    BoardWrap board <- get
    putAndRet (delPost number password board)

putAndRet :: BoardResult -> Update BoardWrap Result
putAndRet result =
    case result of
      Left err -> return $ Left err
      Right (n, board') -> do
        put (BoardWrap board')
        return $ Right n

getBoard' :: Query BoardWrap Board
getBoard' = do
    BoardWrap board <- ask
    return board

---

$(mkMethods ''BoardWrap ['newPost', 'newThread', 'delPost',
                         'putAndRet, 'getBoard'])

instance Component BoardWrap where
    type Dependencies BoardWrap = End
    initialValue = BoardWrap newBoard