diff options
Diffstat (limited to 'Biz/Ibb/Keep.hs')
-rw-r--r-- | Biz/Ibb/Keep.hs | 131 |
1 files changed, 0 insertions, 131 deletions
diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs deleted file mode 100644 index 074a42a..0000000 --- a/Biz/Ibb/Keep.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Keep is a database built on Data.Acid. --- --- If this proves useful, maybe we could make it a more general thing. Like --- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell --- like `$(keep ''MyType)`. -module Biz.Ibb.Keep where - -import Alpha -import Biz.Ibb.Core (Book (..), Person (..)) -import qualified Biz.Ibb.Influencers as Influencers -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Acid (Update, makeAcidic) -import qualified Data.Acid as Acid -import Data.Data (Data, Typeable) -import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet) -import qualified Data.IxSet as IxSet -import Data.SafeCopy -import Data.Text (Text) -import qualified Data.Text as Text - --- * Keep - --- | Main database. Need to think of a better name for this. -newtype IbbKeep = IbbKeep - { _people :: IxSet Person - } - deriving (Data, Typeable) - -$(deriveSafeCopy 0 'base ''IbbKeep) - --- * Index @Person@ - -$(deriveSafeCopy 0 'base ''Person) - -newtype PersonName - = PersonName Text - deriving (Eq, Ord, Data, Typeable) - -newtype PersonBlurb - = PersonBlurb Text - deriving (Eq, Ord, Data, Typeable) - -instance Indexable Person where - empty = - ixSet - [ ixFun <| \p -> [PersonName <| _name p], - ixFun <| \p -> [_pic p], - ixFun <| \p -> [_twitter p], - ixFun <| \p -> [_website p], - ixFun <| \p -> [_books p], - ixFun <| \p -> [PersonBlurb <| _blurb p] - ] - --- | updates the `IbbKeep` with a new `Person` -newPerson :: Text -> Text -> Update IbbKeep Person -newPerson name blurb = do - keep <- get - put - <| k - { _people = IxSet.insert p (_people k) - } - return p - where - p = - Person - { _name = name, - _pic = Text.empty, - _twitter = Text.empty, - _website = Text.empty, - _books = [], - _blurb = blurb - } - -getPeople :: Int -> Acid.Query IbbKeep [Person] -getPeople n = ask /> _people /> IxSet.toList /> take n - --- * Index @Book@ - -$(deriveSafeCopy 0 'base ''Book) - -newtype BookTitle - = BookTitle Text - deriving (Eq, Ord, Data, Typeable) - -newtype BookAuthor - = BookAuthor Text - deriving (Eq, Ord, Data, Typeable) - -instance Indexable Book where - empty = - ixSet - [ ixFun <| \b -> [BookTitle <| _title b], - ixFun <| \b -> [BookAuthor <| _author b], - ixFun <| \b -> [_amznref b] - ] - --- | updates the `IbbKeep` with a new `Book` --- newBook :: Text -> Text -> Text -> Update IbbKeep Book --- newBook title author amznref = do --- ibbKeep <- get --- put <| ibbKeep { _books = IxSet.insert b (_books ibbKeep) --- , _people = _people ibbKeep --- } --- return b --- where --- b = Book { _title = title --- , _author = author --- , _amznref = amznref --- } - --- * Opening the keep - --- defines @NewPerson@ for us. -$(makeAcidic ''IbbKeep ['newPerson, 'getPeople]) - -initialIbbKeep :: IbbKeep -initialIbbKeep = - IbbKeep - { _people = IxSet.fromList Influencers.allPeople - } - -openLocal :: String -> IO (Acid.AcidState IbbKeep) -openLocal dir = - Acid.openLocalStateFrom dir initialIbbKeep |